| 1 |
#' Template: Mixed Model Repeated Measurements (MMRM) Analysis |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate analysis tables and plots for Mixed Model Repeated Measurements. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param method (`string`)\cr a string specifying the adjustment method. |
|
| 7 |
#' @param cor_struct (`string`)\cr a string specifying the correlation structure, defaults to |
|
| 8 |
#' `"unstructured"`. See [tern.mmrm::build_formula()] for more options. |
|
| 9 |
#' @param weights_emmeans argument from [emmeans::emmeans()], "proportional" by default. |
|
| 10 |
#' @param parallel (`flag`)\cr flag that controls whether optimizer search can use available free cores on the |
|
| 11 |
#' machine (not default). |
|
| 12 |
#' |
|
| 13 |
#' @inherit template_arguments return |
|
| 14 |
#' |
|
| 15 |
#' @seealso [tm_a_mmrm()] |
|
| 16 |
#' |
|
| 17 |
#' @keywords internal |
|
| 18 |
template_fit_mmrm <- function(parentname, |
|
| 19 |
dataname, |
|
| 20 |
aval_var, |
|
| 21 |
arm_var, |
|
| 22 |
ref_arm, |
|
| 23 |
comp_arm = NULL, |
|
| 24 |
combine_comp_arms = FALSE, |
|
| 25 |
id_var, |
|
| 26 |
visit_var, |
|
| 27 |
cov_var, |
|
| 28 |
conf_level = 0.95, |
|
| 29 |
method = "Satterthwaite", |
|
| 30 |
cor_struct = "unstructured", |
|
| 31 |
weights_emmeans = "proportional", |
|
| 32 |
parallel = FALSE) {
|
|
| 33 |
# Data |
|
| 34 | 2x |
y <- list() |
| 35 | 2x |
data_list <- list() |
| 36 | 2x |
parent_list <- list() |
| 37 | ||
| 38 | 2x |
if (!is.null(arm_var)) {
|
| 39 | 2x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 40 | ||
| 41 | 2x |
data_list <- add_expr( |
| 42 | 2x |
data_list, |
| 43 | 2x |
prepare_arm( |
| 44 | 2x |
dataname = dataname, |
| 45 | 2x |
arm_var = arm_var, |
| 46 | 2x |
ref_arm = ref_arm, |
| 47 | 2x |
comp_arm = comp_arm, |
| 48 | 2x |
ref_arm_val = ref_arm_val |
| 49 |
) |
|
| 50 |
) |
|
| 51 | ||
| 52 | ||
| 53 | 2x |
parent_list <- add_expr( |
| 54 | 2x |
parent_list, |
| 55 | 2x |
prepare_arm( |
| 56 | 2x |
dataname = parentname, |
| 57 | 2x |
arm_var = arm_var, |
| 58 | 2x |
ref_arm = ref_arm, |
| 59 | 2x |
comp_arm = comp_arm, |
| 60 | 2x |
ref_arm_val = ref_arm_val |
| 61 |
) |
|
| 62 |
) |
|
| 63 | ||
| 64 | 2x |
if (combine_comp_arms) {
|
| 65 | 1x |
data_list <- add_expr( |
| 66 | 1x |
data_list, |
| 67 | 1x |
substitute_names( |
| 68 | 1x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = comp_arm)), |
| 69 | 1x |
names = list(arm_var = as.name(arm_var)), |
| 70 | 1x |
others = list(comp_arm = comp_arm) |
| 71 |
) |
|
| 72 |
) |
|
| 73 | 1x |
parent_list <- add_expr( |
| 74 | 1x |
parent_list, |
| 75 | 1x |
substitute_names( |
| 76 | 1x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = comp_arm)), |
| 77 | 1x |
names = list(arm_var = as.name(arm_var)), |
| 78 | 1x |
others = list(comp_arm = comp_arm) |
| 79 |
) |
|
| 80 |
) |
|
| 81 |
} |
|
| 82 |
} else {
|
|
| 83 | ! |
data_list <- add_expr( |
| 84 | ! |
data_list, |
| 85 | ! |
substitute( |
| 86 | ! |
expr = dataname, |
| 87 | ! |
env = list( |
| 88 | ! |
dataname = as.name(dataname) |
| 89 |
) |
|
| 90 |
) |
|
| 91 |
) |
|
| 92 | ||
| 93 | ! |
parent_list <- add_expr( |
| 94 | ! |
parent_list, |
| 95 | ! |
substitute( |
| 96 | ! |
expr = parentname, |
| 97 | ! |
env = list( |
| 98 | ! |
parentname = as.name(parentname) |
| 99 |
) |
|
| 100 |
) |
|
| 101 |
) |
|
| 102 |
} |
|
| 103 | 2x |
data_list <- add_expr(data_list, quote(df_explicit_na(na_level = default_na_str()))) |
| 104 | 2x |
parent_list <- add_expr(parent_list, quote(df_explicit_na(na_level = default_na_str()))) |
| 105 | ||
| 106 | 2x |
y$data <- substitute( |
| 107 | 2x |
expr = {
|
| 108 | ! |
anl <- data_pipe |
| 109 | ! |
parentname <- parent_pipe |
| 110 |
}, |
|
| 111 | 2x |
env = list( |
| 112 | 2x |
data_pipe = pipe_expr(data_list), |
| 113 | 2x |
parentname = as.name(parentname), |
| 114 | 2x |
parent_pipe = pipe_expr(parent_list) |
| 115 |
) |
|
| 116 |
) |
|
| 117 | ||
| 118 | 2x |
vars <- substitute( |
| 119 | 2x |
expr = list( |
| 120 | 2x |
response = aval_var, |
| 121 | 2x |
covariates = cov_var, |
| 122 | 2x |
id = id_var, |
| 123 | 2x |
arm = arm_var, |
| 124 | 2x |
visit = visit_var |
| 125 |
), |
|
| 126 | 2x |
env = list( |
| 127 | 2x |
aval_var = aval_var, |
| 128 | 2x |
cov_var = cov_var, |
| 129 | 2x |
id_var = id_var, |
| 130 | 2x |
arm_var = arm_var, |
| 131 | 2x |
visit_var = visit_var |
| 132 |
) |
|
| 133 |
) |
|
| 134 | 2x |
y$fit <- substitute( |
| 135 | 2x |
expr = fit <- tern.mmrm::fit_mmrm( |
| 136 | 2x |
vars = vars, |
| 137 | 2x |
data = anl, |
| 138 | 2x |
conf_level = conf_level, |
| 139 | 2x |
method = method, |
| 140 | 2x |
cor_struct = cor_struct, |
| 141 | 2x |
weights_emmeans = weights_emmeans, |
| 142 | 2x |
parallel = parallel |
| 143 |
), |
|
| 144 | 2x |
env = list( |
| 145 | 2x |
vars = vars, |
| 146 | 2x |
conf_level = conf_level, |
| 147 | 2x |
method = method, |
| 148 | 2x |
cor_struct = cor_struct, |
| 149 | 2x |
weights_emmeans = weights_emmeans, |
| 150 | 2x |
parallel = parallel |
| 151 |
) |
|
| 152 |
) |
|
| 153 | ||
| 154 | 2x |
y |
| 155 |
} |
|
| 156 | ||
| 157 |
#' @describeIn template_fit_mmrm Creates valid expressions to generate MMRM LS means, covariance matrix, |
|
| 158 |
#' fixed effects, and diagnostic tables. |
|
| 159 |
#' |
|
| 160 |
#' @inheritParams template_arguments |
|
| 161 |
#' @param fit_name (`string`)\cr name of fitted MMRM object. |
|
| 162 |
#' @param show_relative (`string`)\cr should the "reduction" (`control - treatment`, default) or the "increase" |
|
| 163 |
#' (`treatment - control`) be shown for the relative change from baseline. |
|
| 164 |
#' @param table_type (`string`)\cr type of table to output. |
|
| 165 |
#' |
|
| 166 |
#' @keywords internal |
|
| 167 |
template_mmrm_tables <- function(parentname, |
|
| 168 |
dataname, |
|
| 169 |
fit_name, |
|
| 170 |
arm_var, |
|
| 171 |
ref_arm, |
|
| 172 |
visit_var, |
|
| 173 |
paramcd, |
|
| 174 |
show_relative = c("increase", "reduction", "none"),
|
|
| 175 |
table_type = "t_mmrm_cov", |
|
| 176 |
total_label = default_total_label(), |
|
| 177 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 178 | 2x |
y <- list() |
| 179 | 2x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 180 | ||
| 181 | 2x |
all_basic_table_args <- teal.widgets::resolve_basic_table_args( |
| 182 | 2x |
basic_table_args, |
| 183 | 2x |
module_table = teal.widgets::basic_table_args(show_colcounts = !is.null(arm_var)) |
| 184 |
) |
|
| 185 | ||
| 186 |
# Build layout. |
|
| 187 | 2x |
layout_list <- list() |
| 188 | 2x |
layout_list <- layout_list %>% |
| 189 | 2x |
add_expr(substitute( |
| 190 | 2x |
expr = expr_basic_table_args, |
| 191 | 2x |
env = list(expr_basic_table_args = teal.widgets::parse_basic_table_args(all_basic_table_args)) |
| 192 |
)) |
|
| 193 | ||
| 194 | 2x |
if (!is.null(arm_var)) {
|
| 195 | 1x |
layout_list <- add_expr( |
| 196 | 1x |
layout_list, |
| 197 | 1x |
substitute( |
| 198 | 1x |
expr = rtables::split_cols_by(var = arm_var, ref_group = ref_arm), |
| 199 | 1x |
env = list(arm_var = arm_var, ref_arm = ref_arm_val) |
| 200 |
) |
|
| 201 |
) |
|
| 202 | 1x |
show_relative <- match.arg(show_relative) |
| 203 | ||
| 204 | 1x |
if (show_relative == "none") {
|
| 205 | ! |
layout_list <- add_expr( |
| 206 | ! |
layout_list, |
| 207 | ! |
substitute( |
| 208 | ! |
expr = rtables::split_rows_by(visit_var) %>% |
| 209 | ! |
append_varlabels(dataname, visit_var) %>% |
| 210 | ! |
tern.mmrm::summarize_lsmeans( |
| 211 | ! |
.stats = c( |
| 212 | ! |
"n", |
| 213 | ! |
"adj_mean_se", |
| 214 | ! |
"adj_mean_ci", |
| 215 | ! |
"diff_mean_se", |
| 216 | ! |
"diff_mean_ci", |
| 217 | ! |
"p_value" |
| 218 |
) |
|
| 219 |
) %>% |
|
| 220 | ! |
rtables::append_topleft(paste0(" ", paramcd)),
|
| 221 | ! |
env = list( |
| 222 | ! |
dataname = as.name(dataname), |
| 223 | ! |
visit_var = visit_var, |
| 224 | ! |
paramcd = paramcd |
| 225 |
) |
|
| 226 |
) |
|
| 227 |
) |
|
| 228 |
} else {
|
|
| 229 | 1x |
layout_list <- add_expr( |
| 230 | 1x |
layout_list, |
| 231 | 1x |
substitute( |
| 232 | 1x |
expr = rtables::split_rows_by(visit_var) %>% |
| 233 | 1x |
append_varlabels(dataname, visit_var) %>% |
| 234 | 1x |
tern.mmrm::summarize_lsmeans(show_relative = show_relative) %>% |
| 235 | 1x |
rtables::append_topleft(paste0(" ", paramcd)),
|
| 236 | 1x |
env = list( |
| 237 | 1x |
dataname = as.name(dataname), |
| 238 | 1x |
visit_var = visit_var, |
| 239 | 1x |
paramcd = paramcd, |
| 240 | 1x |
show_relative = show_relative |
| 241 |
) |
|
| 242 |
) |
|
| 243 |
) |
|
| 244 |
} |
|
| 245 |
} else {
|
|
| 246 | 1x |
layout_list <- add_expr( |
| 247 | 1x |
layout_list, |
| 248 | 1x |
substitute( |
| 249 | 1x |
expr = rtables::add_overall_col(total_label) %>% |
| 250 | 1x |
rtables::split_rows_by(visit_var) %>% |
| 251 | 1x |
tern.mmrm::summarize_lsmeans(arms = FALSE) %>% |
| 252 | 1x |
rtables::append_topleft(paste0(" ", paramcd)),
|
| 253 | 1x |
env = list( |
| 254 | 1x |
total_label = total_label, |
| 255 | 1x |
visit_var = visit_var, |
| 256 | 1x |
paramcd = paramcd |
| 257 |
) |
|
| 258 |
) |
|
| 259 |
) |
|
| 260 |
} |
|
| 261 | ||
| 262 | 2x |
y$layout <- substitute( |
| 263 | 2x |
expr = lyt <- layout_pipe, |
| 264 | 2x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 265 |
) |
|
| 266 | ||
| 267 | 2x |
switch(table_type, |
| 268 |
t_mmrm_lsmeans = {
|
|
| 269 | ! |
y$lsmeans_table <- substitute( |
| 270 | ! |
expr = {
|
| 271 | ! |
lsmeans_table <- rtables::build_table( |
| 272 | ! |
lyt = lyt, |
| 273 | ! |
df = df_explicit_na(broom::tidy(fit_mmrm), na_level = default_na_str()), |
| 274 | ! |
alt_counts_df = parentname |
| 275 |
) |
|
| 276 | ! |
lsmeans_table |
| 277 |
}, |
|
| 278 | ! |
env = list( |
| 279 | ! |
parentname = as.name(parentname), |
| 280 | ! |
fit_mmrm = as.name(fit_name) |
| 281 |
) |
|
| 282 |
) |
|
| 283 |
}, |
|
| 284 |
t_mmrm_cov = {
|
|
| 285 | 2x |
y$cov_matrix <- substitute( |
| 286 | 2x |
expr = {
|
| 287 | ! |
cov_matrix <- tern.mmrm::as.rtable(fit_mmrm, type = "cov") |
| 288 | ! |
subtitles(cov_matrix) <- st |
| 289 | ! |
cov_matrix |
| 290 |
}, |
|
| 291 | 2x |
env = list( |
| 292 | 2x |
fit_mmrm = as.name(fit_name), |
| 293 | 2x |
st = basic_table_args$subtitles |
| 294 |
) |
|
| 295 |
) |
|
| 296 |
}, |
|
| 297 |
t_mmrm_fixed = {
|
|
| 298 | ! |
y$fixed_effects <- substitute( |
| 299 | ! |
expr = {
|
| 300 | ! |
fixed_effects <- tern.mmrm::as.rtable(fit_mmrm, type = "fixed") |
| 301 | ! |
subtitles(fixed_effects) <- st |
| 302 | ! |
fixed_effects |
| 303 |
}, |
|
| 304 | ! |
env = list( |
| 305 | ! |
fit_mmrm = as.name(fit_name), |
| 306 | ! |
st = basic_table_args$subtitles |
| 307 |
) |
|
| 308 |
) |
|
| 309 |
}, |
|
| 310 |
t_mmrm_diagnostic = {
|
|
| 311 | ! |
y$diagnostic_table <- substitute( |
| 312 | ! |
expr = {
|
| 313 | ! |
diagnostic_table <- tern.mmrm::as.rtable(fit_mmrm, type = "diagnostic") |
| 314 | ! |
subtitles(diagnostic_table) <- st |
| 315 | ! |
diagnostic_table |
| 316 |
}, |
|
| 317 | ! |
env = list( |
| 318 | ! |
fit_mmrm = as.name(fit_name), |
| 319 | ! |
st = basic_table_args$subtitles |
| 320 |
) |
|
| 321 |
) |
|
| 322 |
} |
|
| 323 |
) |
|
| 324 | 2x |
y |
| 325 |
} |
|
| 326 | ||
| 327 |
#' @describeIn template_fit_mmrm Creates valid expressions to generate MMRM LS means and |
|
| 328 |
#' diagnostic plots. |
|
| 329 |
#' |
|
| 330 |
#' @inheritParams template_arguments |
|
| 331 |
#' @param lsmeans_plot (named `list`)\cr a `list` of controls for LS means plot. |
|
| 332 |
#' See more [tern.mmrm::g_mmrm_lsmeans()]. |
|
| 333 |
#' @param diagnostic_plot (named `list`)\cr a `list` of controls for diagnostic_plot. |
|
| 334 |
#' See more [tern.mmrm::g_mmrm_diagnostic()]. |
|
| 335 |
#' |
|
| 336 |
#' @keywords internal |
|
| 337 |
template_mmrm_plots <- function(fit_name, |
|
| 338 |
lsmeans_plot = list( |
|
| 339 |
select = c("estimates", "contrasts"),
|
|
| 340 |
width = 0.6, |
|
| 341 |
show_pval = FALSE |
|
| 342 |
), |
|
| 343 |
diagnostic_plot = list( |
|
| 344 |
type = "fit-residual", |
|
| 345 |
z_threshold = NULL |
|
| 346 |
), |
|
| 347 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 348 | 1x |
y <- list() |
| 349 | ||
| 350 | 1x |
if (!is.null(lsmeans_plot)) {
|
| 351 | 1x |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 352 | 1x |
teal.widgets::resolve_ggplot2_args( |
| 353 | 1x |
user_plot = ggplot2_args[["lsmeans"]], |
| 354 | 1x |
user_default = ggplot2_args[["default"]] |
| 355 |
) |
|
| 356 |
) |
|
| 357 | ||
| 358 | 1x |
plot_call <- substitute( |
| 359 | 1x |
expr = |
| 360 | 1x |
tern.mmrm::g_mmrm_lsmeans( |
| 361 | 1x |
fit_mmrm, |
| 362 | 1x |
select = select, |
| 363 | 1x |
width = width, |
| 364 | 1x |
show_pval = show_pval, |
| 365 | 1x |
titles = if (is.null(fit_mmrm$vars$arm)) {
|
| 366 | ! |
c( |
| 367 | ! |
estimates = paste("Adjusted mean of", fit_mmrm$labels$response, " at visits"),
|
| 368 | ! |
contrasts = " " |
| 369 |
) |
|
| 370 |
} else {
|
|
| 371 | ! |
c( |
| 372 | ! |
estimates = paste( |
| 373 | ! |
"Adjusted mean of", |
| 374 | ! |
fit_mmrm$labels$response, |
| 375 | ! |
"by treatment at visits" |
| 376 |
), |
|
| 377 | ! |
contrasts = paste0( |
| 378 | ! |
"Differences of ", |
| 379 | ! |
fit_mmrm$labels$response, |
| 380 | ! |
" adjusted means vs. control ('",
|
| 381 | ! |
fit_mmrm$ref_level, |
| 382 |
"')" |
|
| 383 |
) |
|
| 384 |
) |
|
| 385 |
} |
|
| 386 |
), |
|
| 387 | 1x |
env = list( |
| 388 | 1x |
fit_mmrm = as.name(fit_name), |
| 389 | 1x |
select = lsmeans_plot$select, |
| 390 | 1x |
width = lsmeans_plot$width, |
| 391 | 1x |
show_pval = lsmeans_plot$show_pval |
| 392 |
) |
|
| 393 |
) |
|
| 394 | ||
| 395 | 1x |
y$lsmeans_plot <- substitute( |
| 396 | 1x |
expr = {
|
| 397 | ! |
lsmeans_plot <- plot_call |
| 398 | ! |
lsmeans_plot |
| 399 |
}, |
|
| 400 | 1x |
env = list( |
| 401 | 1x |
plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))
|
| 402 |
) |
|
| 403 |
) |
|
| 404 |
} |
|
| 405 | ||
| 406 | 1x |
if (!is.null(diagnostic_plot)) {
|
| 407 | 1x |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 408 | 1x |
teal.widgets::resolve_ggplot2_args( |
| 409 | 1x |
user_plot = ggplot2_args[["diagnostic"]], |
| 410 | 1x |
user_default = ggplot2_args[["default"]] |
| 411 |
) |
|
| 412 |
) |
|
| 413 | ||
| 414 | 1x |
plot_call <- substitute( |
| 415 | 1x |
expr = |
| 416 | 1x |
tern.mmrm::g_mmrm_diagnostic( |
| 417 | 1x |
fit_mmrm, |
| 418 | 1x |
type = type, |
| 419 | 1x |
z_threshold = z_threshold |
| 420 |
), |
|
| 421 | 1x |
env = list( |
| 422 | 1x |
fit_mmrm = as.name(fit_name), |
| 423 | 1x |
type = diagnostic_plot$type, |
| 424 | 1x |
z_threshold = diagnostic_plot$z_threshold |
| 425 |
) |
|
| 426 |
) |
|
| 427 | ||
| 428 | 1x |
y$diagnostic_plot <- substitute( |
| 429 | 1x |
expr = {
|
| 430 | ! |
diagnostic_plot <- plot_call |
| 431 | ! |
diagnostic_plot |
| 432 |
}, |
|
| 433 | 1x |
env = list( |
| 434 | 1x |
plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))
|
| 435 |
) |
|
| 436 |
) |
|
| 437 |
} |
|
| 438 | ||
| 439 | 1x |
y |
| 440 |
} |
|
| 441 | ||
| 442 |
#' teal Module: Mixed Model Repeated Measurements (MMRM) Analysis |
|
| 443 |
#' |
|
| 444 |
#' This module produces analysis tables and plots for Mixed Model Repeated Measurements. |
|
| 445 |
#' |
|
| 446 |
#' @inheritParams module_arguments |
|
| 447 |
#' @inheritParams template_mmrm_tables |
|
| 448 |
#' @inheritParams template_mmrm_plots |
|
| 449 |
#' @param method ([teal.transform::choices_selected()])\cr object with |
|
| 450 |
#' all available choices and pre-selected option for the adjustment method. |
|
| 451 |
#' @param ggplot2_args (`ggplot2_args`) optional\cr object created by [`teal.widgets::ggplot2_args()`] |
|
| 452 |
#' with settings for all the plots or named list of `ggplot2_args` objects for plot-specific settings. |
|
| 453 |
#' List names should match the following: `c("default", "lsmeans", "diagnostic")`. The argument is merged
|
|
| 454 |
#' with option `teal.ggplot2_args` and with default module arguments (hard coded in the module body). |
|
| 455 |
#' For more details, see the help vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`.
|
|
| 456 |
#' |
|
| 457 |
#' @note |
|
| 458 |
#' The ordering of the input data sets can lead to slightly different numerical results or |
|
| 459 |
#' different convergence behavior. This is a known observation with the used package |
|
| 460 |
#' `lme4`. However, once convergence is achieved, the results are reliable up to |
|
| 461 |
#' numerical precision. |
|
| 462 |
#' |
|
| 463 |
#' @inherit module_arguments return seealso |
|
| 464 |
#' |
|
| 465 |
#' @examples |
|
| 466 |
#' library(dplyr) |
|
| 467 |
#' arm_ref_comp <- list( |
|
| 468 |
#' ARMCD = list( |
|
| 469 |
#' ref = "ARM B", |
|
| 470 |
#' comp = c("ARM A", "ARM C")
|
|
| 471 |
#' ) |
|
| 472 |
#' ) |
|
| 473 |
#' |
|
| 474 |
#' data <- teal_data() |
|
| 475 |
#' data <- within(data, {
|
|
| 476 |
#' ADSL <- tmc_ex_adsl |
|
| 477 |
#' ADQS <- tmc_ex_adqs %>% |
|
| 478 |
#' filter(ABLFL != "Y" & ABLFL2 != "Y") %>% |
|
| 479 |
#' filter(AVISIT %in% c("WEEK 1 DAY 8", "WEEK 2 DAY 15", "WEEK 3 DAY 22")) %>%
|
|
| 480 |
#' mutate( |
|
| 481 |
#' AVISIT = as.factor(AVISIT), |
|
| 482 |
#' AVISITN = rank(AVISITN) %>% |
|
| 483 |
#' as.factor() %>% |
|
| 484 |
#' as.numeric() %>% |
|
| 485 |
#' as.factor() #' making consecutive numeric factor |
|
| 486 |
#' ) |
|
| 487 |
#' }) |
|
| 488 |
#' |
|
| 489 |
#' datanames <- c("ADSL", "ADQS")
|
|
| 490 |
#' datanames(data) <- datanames |
|
| 491 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 492 |
#' app <- init( |
|
| 493 |
#' data = data, |
|
| 494 |
#' modules = modules( |
|
| 495 |
#' tm_a_mmrm( |
|
| 496 |
#' label = "MMRM", |
|
| 497 |
#' dataname = "ADQS", |
|
| 498 |
#' aval_var = choices_selected(c("AVAL", "CHG"), "AVAL"),
|
|
| 499 |
#' id_var = choices_selected(c("USUBJID", "SUBJID"), "USUBJID"),
|
|
| 500 |
#' arm_var = choices_selected(c("ARM", "ARMCD"), "ARM"),
|
|
| 501 |
#' visit_var = choices_selected(c("AVISIT", "AVISITN"), "AVISIT"),
|
|
| 502 |
#' arm_ref_comp = arm_ref_comp, |
|
| 503 |
#' paramcd = choices_selected( |
|
| 504 |
#' choices = value_choices(data[["ADQS"]], "PARAMCD", "PARAM"), |
|
| 505 |
#' selected = "FKSI-FWB" |
|
| 506 |
#' ), |
|
| 507 |
#' cov_var = choices_selected(c("BASE", "AGE", "SEX", "BASE:AVISIT"), NULL)
|
|
| 508 |
#' ) |
|
| 509 |
#' ) |
|
| 510 |
#' ) |
|
| 511 |
#' if (interactive()) {
|
|
| 512 |
#' shinyApp(app$ui, app$server) |
|
| 513 |
#' } |
|
| 514 |
#' |
|
| 515 |
#' @export |
|
| 516 |
tm_a_mmrm <- function(label, |
|
| 517 |
dataname, |
|
| 518 |
parentname = ifelse( |
|
| 519 |
inherits(arm_var, "data_extract_spec"), |
|
| 520 |
teal.transform::datanames_input(arm_var), |
|
| 521 |
"ADSL" |
|
| 522 |
), |
|
| 523 |
aval_var, |
|
| 524 |
id_var, |
|
| 525 |
arm_var, |
|
| 526 |
visit_var, |
|
| 527 |
cov_var, |
|
| 528 |
arm_ref_comp = NULL, |
|
| 529 |
paramcd, |
|
| 530 |
method = teal.transform::choices_selected( |
|
| 531 |
c("Satterthwaite", "Kenward-Roger", "Kenward-Roger-Linear"),
|
|
| 532 |
"Satterthwaite", |
|
| 533 |
keep_order = TRUE |
|
| 534 |
), |
|
| 535 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 536 |
plot_height = c(700L, 200L, 2000L), |
|
| 537 |
plot_width = NULL, |
|
| 538 |
total_label = default_total_label(), |
|
| 539 |
pre_output = NULL, |
|
| 540 |
post_output = NULL, |
|
| 541 |
basic_table_args = teal.widgets::basic_table_args(), |
|
| 542 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 543 | ! |
message("Initializing tm_a_mmrm")
|
| 544 | ! |
cov_var <- teal.transform::add_no_selected_choices(cov_var, multiple = TRUE) |
| 545 | ! |
checkmate::assert_string(label) |
| 546 | ! |
checkmate::assert_string(total_label) |
| 547 | ! |
checkmate::assert_string(dataname) |
| 548 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 549 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 550 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 551 | ! |
checkmate::assert_class(visit_var, "choices_selected") |
| 552 | ! |
checkmate::assert_class(cov_var, "choices_selected") |
| 553 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 554 | ! |
checkmate::assert_class(method, "choices_selected") |
| 555 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 556 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 557 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 558 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 559 | ! |
checkmate::assert_numeric( |
| 560 | ! |
plot_width[1], |
| 561 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 562 |
) |
|
| 563 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 564 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 565 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 566 | ! |
if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) |
| 567 | ! |
plot_choices <- c("lsmeans", "diagnostic")
|
| 568 | ! |
checkmate::assert_list(ggplot2_args, types = "ggplot2_args") |
| 569 | ! |
checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices))
|
| 570 | ||
| 571 | ! |
args <- as.list(environment()) |
| 572 | ||
| 573 | ! |
data_extract_list <- list( |
| 574 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 575 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 576 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 577 | ! |
visit_var = cs_to_des_select(visit_var, dataname = dataname), |
| 578 | ! |
cov_var = cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE), |
| 579 | ! |
split_covariates = cs_to_des_select(split_choices(cov_var), dataname = dataname, multiple = TRUE), |
| 580 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname) |
| 581 |
) |
|
| 582 | ||
| 583 | ! |
module( |
| 584 | ! |
label = label, |
| 585 | ! |
server = srv_mmrm, |
| 586 | ! |
ui = ui_mmrm, |
| 587 | ! |
ui_args = c(data_extract_list, args), |
| 588 | ! |
server_args = c( |
| 589 | ! |
data_extract_list, |
| 590 | ! |
list( |
| 591 | ! |
dataname = dataname, |
| 592 | ! |
parentname = parentname, |
| 593 | ! |
arm_ref_comp = arm_ref_comp, |
| 594 | ! |
label = label, |
| 595 | ! |
total_label = total_label, |
| 596 | ! |
plot_height = plot_height, |
| 597 | ! |
plot_width = plot_width, |
| 598 | ! |
basic_table_args = basic_table_args, |
| 599 | ! |
ggplot2_args = ggplot2_args |
| 600 |
) |
|
| 601 |
), |
|
| 602 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 603 |
) |
|
| 604 |
} |
|
| 605 | ||
| 606 |
#' @keywords internal |
|
| 607 |
ui_mmrm <- function(id, ...) {
|
|
| 608 | ! |
a <- list(...) # module args |
| 609 | ! |
ns <- NS(id) |
| 610 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 611 | ! |
a$arm_var, |
| 612 | ! |
a$paramcd, |
| 613 | ! |
a$id_var, |
| 614 | ! |
a$visit_var, |
| 615 | ! |
a$cov_var, |
| 616 | ! |
a$aval_var |
| 617 |
) |
|
| 618 | ||
| 619 | ! |
tagList( |
| 620 | ! |
singleton( |
| 621 | ! |
tags$head(includeCSS(system.file("css/custom.css", package = "teal.modules.clinical")))
|
| 622 |
), |
|
| 623 | ! |
teal.widgets::standard_layout( |
| 624 | ! |
output = teal.widgets::white_small_well( |
| 625 | ! |
textOutput(ns("null_input_msg")),
|
| 626 | ! |
tags$h3(textOutput(ns("mmrm_title"))),
|
| 627 | ! |
teal.widgets::table_with_settings_ui(ns("mmrm_table")),
|
| 628 | ! |
teal.widgets::plot_with_settings_ui(id = ns("mmrm_plot"))
|
| 629 |
), |
|
| 630 | ! |
encoding = tags$div( |
| 631 |
### Reporter |
|
| 632 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 633 |
### |
|
| 634 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 635 | ! |
teal.transform::datanames_input(a[c("arm_var", "paramcd", "id_var", "visit_var", "cov_var", "aval_var")]),
|
| 636 | ! |
teal.widgets::panel_group( |
| 637 | ! |
teal.widgets::panel_item( |
| 638 | ! |
"Model Settings", |
| 639 | ! |
teal.transform::data_extract_ui( |
| 640 | ! |
id = ns("aval_var"),
|
| 641 | ! |
label = "Analysis Variable", |
| 642 | ! |
data_extract_spec = a$aval_var, |
| 643 | ! |
is_single_dataset = is_single_dataset_value |
| 644 |
), |
|
| 645 | ! |
teal.transform::data_extract_ui( |
| 646 | ! |
id = ns("paramcd"),
|
| 647 | ! |
label = "Select Endpoint", |
| 648 | ! |
data_extract_spec = a$paramcd, |
| 649 | ! |
is_single_dataset = is_single_dataset_value |
| 650 |
), |
|
| 651 | ! |
teal.transform::data_extract_ui( |
| 652 | ! |
id = ns("visit_var"),
|
| 653 | ! |
label = "Visit Variable", |
| 654 | ! |
data_extract_spec = a$visit_var, |
| 655 | ! |
is_single_dataset = is_single_dataset_value |
| 656 |
), |
|
| 657 | ! |
teal.transform::data_extract_ui( |
| 658 | ! |
id = ns("cov_var"),
|
| 659 | ! |
label = "Covariates", |
| 660 | ! |
data_extract_spec = a$cov_var, |
| 661 | ! |
is_single_dataset = is_single_dataset_value |
| 662 |
), |
|
| 663 | ! |
shinyjs::hidden( |
| 664 | ! |
teal.transform::data_extract_ui( |
| 665 | ! |
id = ns("split_covariates"),
|
| 666 | ! |
label = "Split Covariates", |
| 667 | ! |
data_extract_spec = a$split_covariates, |
| 668 | ! |
is_single_dataset = is_single_dataset_value |
| 669 |
) |
|
| 670 |
), |
|
| 671 | ! |
teal.transform::data_extract_ui( |
| 672 | ! |
id = ns("arm_var"),
|
| 673 | ! |
label = "Select Treatment Variable", |
| 674 | ! |
data_extract_spec = a$arm_var, |
| 675 | ! |
is_single_dataset = is_single_dataset_value |
| 676 |
), |
|
| 677 | ! |
shinyjs::hidden(uiOutput(ns("arms_buckets"))),
|
| 678 | ! |
shinyjs::hidden( |
| 679 | ! |
helpText( |
| 680 | ! |
id = ns("help_text"), "Multiple reference groups are automatically combined into a single group."
|
| 681 |
) |
|
| 682 |
), |
|
| 683 | ! |
shinyjs::hidden( |
| 684 | ! |
checkboxInput( |
| 685 | ! |
ns("combine_comp_arms"),
|
| 686 | ! |
"Combine all comparison groups?", |
| 687 | ! |
value = FALSE |
| 688 |
) |
|
| 689 |
), |
|
| 690 | ! |
teal.transform::data_extract_ui( |
| 691 | ! |
id = ns("id_var"),
|
| 692 | ! |
label = "Subject Identifier", |
| 693 | ! |
data_extract_spec = a$id_var, |
| 694 | ! |
is_single_dataset = is_single_dataset_value |
| 695 |
), |
|
| 696 | ! |
selectInput( |
| 697 | ! |
ns("weights_emmeans"),
|
| 698 | ! |
"Weights for LS means", |
| 699 | ! |
choices = c("proportional", "equal"),
|
| 700 | ! |
selected = "proportional", |
| 701 | ! |
multiple = FALSE |
| 702 |
), |
|
| 703 | ! |
selectInput( |
| 704 | ! |
ns("cor_struct"),
|
| 705 | ! |
"Correlation Structure", |
| 706 | ! |
choices = eval(formals(tern.mmrm::build_formula)$cor_struct), |
| 707 | ! |
multiple = FALSE |
| 708 |
), |
|
| 709 | ! |
teal.widgets::optionalSelectInput( |
| 710 | ! |
ns("method"),
|
| 711 | ! |
"Adjustment Method", |
| 712 | ! |
a$method$choices, |
| 713 | ! |
a$method$selected, |
| 714 | ! |
multiple = FALSE, |
| 715 | ! |
fixed = a$method$fixed |
| 716 |
), |
|
| 717 | ! |
teal.widgets::optionalSelectInput( |
| 718 | ! |
ns("conf_level"),
|
| 719 | ! |
"Confidence Level", |
| 720 | ! |
a$conf_level$choices, |
| 721 | ! |
a$conf_level$selected, |
| 722 | ! |
multiple = FALSE, |
| 723 | ! |
fixed = a$conf_level$fixed |
| 724 |
), |
|
| 725 | ! |
checkboxInput( |
| 726 | ! |
ns("parallel"),
|
| 727 | ! |
"Parallel Computing", |
| 728 | ! |
value = TRUE |
| 729 |
), |
|
| 730 | ! |
collapsed = FALSE # Start with having this panel opened. |
| 731 |
) |
|
| 732 |
), |
|
| 733 | ! |
actionButton( |
| 734 | ! |
ns("button_start"),
|
| 735 | ! |
"Fit Model", |
| 736 | ! |
icon = icon("calculator"),
|
| 737 | ! |
width = "100%", |
| 738 | ! |
class = "btn action-button text-dark bg-orange mb-4" |
| 739 |
), |
|
| 740 | ! |
radioButtons( |
| 741 | ! |
ns("output_function"),
|
| 742 | ! |
"Output Type", |
| 743 | ! |
choices = c( |
| 744 | ! |
"LS means table" = "t_mmrm_lsmeans", |
| 745 | ! |
"LS means plots" = "g_mmrm_lsmeans", |
| 746 | ! |
"Covariance estimate" = "t_mmrm_cov", |
| 747 | ! |
"Fixed effects" = "t_mmrm_fixed", |
| 748 | ! |
"Fit statistics" = "t_mmrm_diagnostic", |
| 749 | ! |
"Diagnostic plots" = "g_mmrm_diagnostic" |
| 750 |
), |
|
| 751 | ! |
selected = "t_mmrm_lsmeans" |
| 752 |
), |
|
| 753 | ! |
conditionalPanel( |
| 754 | ! |
condition = paste0( |
| 755 | ! |
"input['", ns("output_function"), "'] == 't_mmrm_lsmeans'", " || ",
|
| 756 | ! |
"input['", ns("output_function"), "'] == 'g_mmrm_lsmeans'", " || ",
|
| 757 | ! |
"input['", ns("output_function"), "'] == 'g_mmrm_diagnostic'"
|
| 758 |
), |
|
| 759 | ! |
teal.widgets::panel_group( |
| 760 | ! |
teal.widgets::panel_item( |
| 761 | ! |
"Output Settings", |
| 762 |
# Additional option for LS means table. |
|
| 763 | ! |
selectInput( |
| 764 | ! |
ns("t_mmrm_lsmeans_show_relative"),
|
| 765 | ! |
"Show Relative Change", |
| 766 | ! |
choices = c("reduction", "increase", "none"),
|
| 767 | ! |
selected = "reduction", |
| 768 | ! |
multiple = FALSE |
| 769 |
), |
|
| 770 | ! |
checkboxGroupInput( |
| 771 | ! |
ns("g_mmrm_lsmeans_select"),
|
| 772 | ! |
"LS means plots", |
| 773 | ! |
choices = c( |
| 774 | ! |
"Estimates" = "estimates", |
| 775 | ! |
"Contrasts" = "contrasts" |
| 776 |
), |
|
| 777 | ! |
selected = c("estimates", "contrasts"),
|
| 778 | ! |
inline = TRUE |
| 779 |
), |
|
| 780 | ! |
sliderInput( |
| 781 | ! |
ns("g_mmrm_lsmeans_width"),
|
| 782 | ! |
"CI bar width", |
| 783 | ! |
min = 0.1, |
| 784 | ! |
max = 1, |
| 785 | ! |
value = 0.6 |
| 786 |
), |
|
| 787 | ! |
checkboxInput( |
| 788 | ! |
ns("g_mmrm_lsmeans_contrasts_show_pval"),
|
| 789 | ! |
"Show contrasts p-values", |
| 790 | ! |
value = FALSE |
| 791 |
), |
|
| 792 |
# Additional options for diagnostic plots. |
|
| 793 | ! |
radioButtons( |
| 794 | ! |
ns("g_mmrm_diagnostic_type"),
|
| 795 | ! |
"Diagnostic plot type", |
| 796 | ! |
choices = c( |
| 797 | ! |
"Fitted vs. Residuals" = "fit-residual", |
| 798 | ! |
"Normal Q-Q Plot of Residuals" = "q-q-residual" |
| 799 |
), |
|
| 800 | ! |
selected = NULL |
| 801 |
), |
|
| 802 | ! |
sliderInput( |
| 803 | ! |
ns("g_mmrm_diagnostic_z_threshold"),
|
| 804 | ! |
"Label observations above this threshold", |
| 805 | ! |
min = 0.1, |
| 806 | ! |
max = 10, |
| 807 | ! |
value = 3 |
| 808 |
) |
|
| 809 |
) |
|
| 810 |
) |
|
| 811 |
) |
|
| 812 |
) |
|
| 813 |
), |
|
| 814 | ! |
forms = tagList( |
| 815 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 816 |
), |
|
| 817 | ! |
pre_output = a$pre_output, |
| 818 | ! |
post_output = a$post_output |
| 819 |
) |
|
| 820 |
} |
|
| 821 | ||
| 822 |
#' @keywords internal |
|
| 823 |
srv_mmrm <- function(id, |
|
| 824 |
data, |
|
| 825 |
reporter, |
|
| 826 |
filter_panel_api, |
|
| 827 |
dataname, |
|
| 828 |
parentname, |
|
| 829 |
arm_var, |
|
| 830 |
paramcd, |
|
| 831 |
id_var, |
|
| 832 |
visit_var, |
|
| 833 |
cov_var, |
|
| 834 |
split_covariates, |
|
| 835 |
aval_var, |
|
| 836 |
arm_ref_comp, |
|
| 837 |
label, |
|
| 838 |
total_label, |
|
| 839 |
plot_height, |
|
| 840 |
plot_width, |
|
| 841 |
basic_table_args, |
|
| 842 |
ggplot2_args) {
|
|
| 843 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 844 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 845 | ! |
checkmate::assert_class(data, "reactive") |
| 846 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 847 | ||
| 848 | ! |
moduleServer(id, function(input, output, session) {
|
| 849 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 850 |
# Reactive responsible for sending a disable/enable signal |
|
| 851 |
# to show R code and debug info buttons |
|
| 852 | ! |
disable_r_code <- reactiveVal(FALSE) |
| 853 | ||
| 854 | ! |
observeEvent(input[[extract_input("cov_var", dataname)]], {
|
| 855 |
# update covariates as actual variables |
|
| 856 | ! |
split_interactions_values <- split_interactions(input[[extract_input("cov_var", dataname)]])
|
| 857 | ! |
arm_var_value <- input[[extract_input("arm_var", parentname)]]
|
| 858 | ! |
arm_in_cov <- length(intersect(split_interactions_values, arm_var_value)) >= 1L |
| 859 | ! |
if (arm_in_cov) {
|
| 860 | ! |
split_covariates_selected <- setdiff(split_interactions_values, arm_var_value) |
| 861 |
} else {
|
|
| 862 | ! |
split_covariates_selected <- split_interactions_values |
| 863 |
} |
|
| 864 | ! |
teal.widgets::updateOptionalSelectInput( |
| 865 | ! |
session, |
| 866 | ! |
inputId = extract_input("split_covariates", dataname),
|
| 867 | ! |
selected = split_covariates_selected |
| 868 |
) |
|
| 869 |
}) |
|
| 870 | ||
| 871 | ! |
arm_ref_comp_iv <- arm_ref_comp_observer( |
| 872 | ! |
session, |
| 873 | ! |
input, |
| 874 | ! |
output, |
| 875 | ! |
id_arm_var = extract_input("arm_var", parentname), # From UI.
|
| 876 | ! |
data = reactive(data()[[parentname]]), |
| 877 | ! |
arm_ref_comp = arm_ref_comp, |
| 878 | ! |
module = "tm_mmrm" |
| 879 |
) |
|
| 880 | ||
| 881 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 882 | ! |
data_extract = list( |
| 883 | ! |
arm_var = arm_var, |
| 884 | ! |
paramcd = paramcd, |
| 885 | ! |
id_var = id_var, |
| 886 | ! |
visit_var = visit_var, |
| 887 | ! |
split_covariates = split_covariates, |
| 888 | ! |
cov_var = cov_var, # only needed for validation see selector_list_without_cov reactive |
| 889 | ! |
aval_var = aval_var |
| 890 |
), |
|
| 891 | ! |
datasets = data, |
| 892 | ! |
select_validation_rule = list( |
| 893 | ! |
aval_var = shinyvalidate::sv_required("'Analysis Variable' field is not selected"),
|
| 894 | ! |
visit_var = shinyvalidate::sv_required("'Visit Variable' field is not selected"),
|
| 895 | ! |
arm_var = shinyvalidate::sv_required("'Treatment Variable' field is not selected"),
|
| 896 | ! |
id_var = shinyvalidate::sv_required("'Subject Identifier' field is not selected"),
|
| 897 |
# validation on cov_var |
|
| 898 | ! |
cov_var = function(value) {
|
| 899 | ! |
if (length(selector_list()$visit_var()$select) == 0) {
|
| 900 | ! |
return(NULL) |
| 901 |
} |
|
| 902 | ! |
if ("BASE:AVISIT" %in% value && selector_list()$visit_var()$select == "AVISITN") {
|
| 903 | ! |
paste( |
| 904 | ! |
"'BASE:AVISIT' is not a valid covariate when 'AVISITN' is selected as visit variable.", |
| 905 | ! |
"Please deselect 'BASE:AVISIT' as a covariate or change visit variable to 'AVISIT'." |
| 906 |
) |
|
| 907 | ! |
} else if ("BASE:AVISITN" %in% value && selector_list()$visit_var()$select == "AVISIT") {
|
| 908 | ! |
paste( |
| 909 | ! |
"'BASE:AVISITN' is not a valid covariate when 'AVISIT' is selected as visit variable.", |
| 910 | ! |
"Please deselect 'BASE:AVISITN' as a covariate or change visit variable to 'AVISITN'." |
| 911 |
) |
|
| 912 |
} |
|
| 913 |
} |
|
| 914 |
), |
|
| 915 | ! |
filter_validation_rule = list( |
| 916 | ! |
paramcd = shinyvalidate::sv_required("'Select Endpoint' field is not selected")
|
| 917 |
) |
|
| 918 |
) |
|
| 919 | ||
| 920 |
# selector_list includes cov_var as it is needed for validation rules |
|
| 921 |
# but not needed to merge so it is removed here |
|
| 922 | ! |
selector_list_without_cov <- reactive({
|
| 923 | ! |
selector_list()[names(selector_list()) != "cov_var"] |
| 924 |
}) |
|
| 925 | ||
| 926 | ! |
iv_r <- reactive({
|
| 927 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 928 | ! |
iv$add_validator(arm_ref_comp_iv) |
| 929 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("'Confidence Level' field is not selected"))
|
| 930 | ! |
iv$add_rule( |
| 931 | ! |
"conf_level", |
| 932 | ! |
shinyvalidate::sv_between( |
| 933 | ! |
0, 1, |
| 934 | ! |
message_fmt = "Confidence level must be between 0 and 1" |
| 935 |
) |
|
| 936 |
) |
|
| 937 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 938 |
}) |
|
| 939 | ||
| 940 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 941 | ! |
datasets = data, |
| 942 | ! |
selector_list = selector_list_without_cov, |
| 943 | ! |
merge_function = "dplyr::inner_join" |
| 944 |
) |
|
| 945 | ||
| 946 | ! |
adsl_merge_inputs <- teal.transform::merge_expression_module( |
| 947 | ! |
datasets = data, |
| 948 | ! |
data_extract = list(arm_var = arm_var), |
| 949 | ! |
anl_name = "ANL_ADSL" |
| 950 |
) |
|
| 951 | ||
| 952 | ! |
anl_q <- reactive({
|
| 953 | ! |
data() %>% |
| 954 | ! |
teal.code::eval_code(code = as.expression(anl_inputs()$expr)) %>% |
| 955 | ! |
teal.code::eval_code(code = as.expression(adsl_merge_inputs()$expr)) |
| 956 |
}) |
|
| 957 | ||
| 958 |
# Initially hide the output title because there is no output yet. |
|
| 959 | ! |
shinyjs::hide("mmrm_title")
|
| 960 | ||
| 961 |
# reactiveVal used to send a signal to plot_with_settings module to hide the UI |
|
| 962 | ! |
show_plot_rv <- reactiveVal(FALSE) |
| 963 | ||
| 964 |
# this will store the current/last state of inputs and data that generated a model-fit |
|
| 965 |
# its purpose is to allow any input change to be checked whether it resulted in an out of sync state |
|
| 966 | ! |
state <- reactiveValues(input = NULL, button_start = 0) |
| 967 | ||
| 968 |
# Note: |
|
| 969 |
# input$parallel does not get us out of sync (it just takes longer to get to same result) |
|
| 970 | ! |
sync_inputs <- c( |
| 971 | ! |
extract_input("aval_var", dataname),
|
| 972 | ! |
extract_input("paramcd", dataname, filter = TRUE),
|
| 973 | ! |
extract_input("arm_var", parentname),
|
| 974 | ! |
"Ref", |
| 975 | ! |
"Comp", |
| 976 | ! |
"combine_comp_arms", |
| 977 | ! |
extract_input("visit_var", dataname),
|
| 978 | ! |
extract_input("cov_var", dataname),
|
| 979 | ! |
extract_input("id_var", dataname),
|
| 980 | ! |
"weights_emmeans", |
| 981 | ! |
"cor_struct", |
| 982 | ! |
"method", |
| 983 | ! |
"conf_level" |
| 984 |
) |
|
| 985 | ||
| 986 |
# Setup arm variable selection, default reference arms, and default |
|
| 987 |
# comparison arms for encoding panel. |
|
| 988 | ||
| 989 | ! |
observeEvent(adsl_merge_inputs()$columns_source$arm_var, {
|
| 990 | ! |
arm_var <- as.vector(adsl_merge_inputs()$columns_source$arm_var) |
| 991 | ! |
if (length(arm_var) == 0) {
|
| 992 | ! |
shinyjs::hide("arms_buckets")
|
| 993 | ! |
shinyjs::hide("help_text")
|
| 994 | ! |
shinyjs::hide("combine_comp_arms")
|
| 995 |
} else {
|
|
| 996 | ! |
shinyjs::show("arms_buckets")
|
| 997 | ! |
shinyjs::show("help_text")
|
| 998 | ! |
shinyjs::show("combine_comp_arms")
|
| 999 |
} |
|
| 1000 |
}) |
|
| 1001 | ||
| 1002 |
# Event handler: |
|
| 1003 |
# Show either the plot or the table output. |
|
| 1004 | ! |
observeEvent(input$output_function, {
|
| 1005 | ! |
output_function <- input$output_function |
| 1006 | ! |
if (isTRUE(grepl("^t_", output_function))) {
|
| 1007 | ! |
show_plot_rv(FALSE) |
| 1008 | ! |
shinyjs::show("mmrm_table")
|
| 1009 | ! |
} else if (isTRUE(grepl("^g_", output_function))) {
|
| 1010 | ! |
shinyjs::hide("mmrm_table")
|
| 1011 | ! |
show_plot_rv(TRUE) |
| 1012 |
} else {
|
|
| 1013 | ! |
stop("unknown output type")
|
| 1014 |
} |
|
| 1015 |
}) |
|
| 1016 | ||
| 1017 |
# Event handler: |
|
| 1018 |
# Show or hide LS means table option. |
|
| 1019 | ! |
observeEvent(input$output_function, {
|
| 1020 | ! |
output_function <- input$output_function |
| 1021 | ! |
if (isTRUE(output_function == "t_mmrm_lsmeans")) {
|
| 1022 | ! |
shinyjs::show("t_mmrm_lsmeans_show_relative")
|
| 1023 |
} else {
|
|
| 1024 | ! |
shinyjs::hide("t_mmrm_lsmeans_show_relative")
|
| 1025 |
} |
|
| 1026 |
}) |
|
| 1027 | ||
| 1028 |
# Event handler: |
|
| 1029 |
# Show or hide the LS means plot options. |
|
| 1030 | ! |
observeEvent(list(input$output_function, input$g_mmrm_lsmeans_select), {
|
| 1031 | ! |
output_function <- input$output_function |
| 1032 | ! |
g_mmrm_lsmeans_select <- input$g_mmrm_lsmeans_select |
| 1033 | ! |
if (isTRUE(output_function == "g_mmrm_lsmeans")) {
|
| 1034 | ! |
shinyjs::show("g_mmrm_lsmeans_select")
|
| 1035 | ! |
shinyjs::show("g_mmrm_lsmeans_width")
|
| 1036 | ! |
if (isTRUE("contrasts" %in% g_mmrm_lsmeans_select)) {
|
| 1037 | ! |
shinyjs::show("g_mmrm_lsmeans_contrasts_show_pval")
|
| 1038 |
} else {
|
|
| 1039 | ! |
shinyjs::hide("g_mmrm_lsmeans_contrasts_show_pval")
|
| 1040 |
} |
|
| 1041 |
} else {
|
|
| 1042 | ! |
shinyjs::hide("g_mmrm_lsmeans_select")
|
| 1043 | ! |
shinyjs::hide("g_mmrm_lsmeans_width")
|
| 1044 | ! |
shinyjs::hide("g_mmrm_lsmeans_contrasts_show_pval")
|
| 1045 |
} |
|
| 1046 |
}) |
|
| 1047 | ||
| 1048 |
# Event handler: |
|
| 1049 |
# Show or hide the diagnostic plot type option. |
|
| 1050 | ! |
observeEvent(list(input$output_function, input$g_mmrm_diagnostic_type), {
|
| 1051 | ! |
output_function <- input$output_function |
| 1052 | ! |
g_mmrm_diagnostic_type <- input$g_mmrm_diagnostic_type |
| 1053 | ! |
if (isTRUE(output_function == "g_mmrm_diagnostic")) {
|
| 1054 | ! |
shinyjs::show("g_mmrm_diagnostic_type")
|
| 1055 | ! |
if (isTRUE(g_mmrm_diagnostic_type == "q-q-residual")) {
|
| 1056 | ! |
shinyjs::show("g_mmrm_diagnostic_z_threshold")
|
| 1057 |
} else {
|
|
| 1058 | ! |
shinyjs::hide("g_mmrm_diagnostic_z_threshold")
|
| 1059 |
} |
|
| 1060 |
} else {
|
|
| 1061 | ! |
shinyjs::hide("g_mmrm_diagnostic_type")
|
| 1062 | ! |
shinyjs::hide("g_mmrm_diagnostic_z_threshold")
|
| 1063 |
} |
|
| 1064 |
}) |
|
| 1065 | ||
| 1066 |
# Event handler: |
|
| 1067 |
# When the "Fit Model" button is clicked, hide initial message, show title, disable model fit and enable |
|
| 1068 |
# show R code buttons. |
|
| 1069 | ! |
shinyjs::onclick("button_start", {
|
| 1070 | ! |
state$input <- mmrm_inputs_reactive() |
| 1071 | ! |
shinyjs::hide("null_input_msg")
|
| 1072 | ! |
shinyjs::disable("button_start")
|
| 1073 | ! |
success <- try(mmrm_fit(), silent = TRUE) |
| 1074 | ! |
if (!inherits(success, "try-error")) {
|
| 1075 | ! |
shinyjs::show("mmrm_title")
|
| 1076 | ! |
disable_r_code(FALSE) |
| 1077 |
} else {
|
|
| 1078 | ! |
shinyjs::hide("mmrm_title")
|
| 1079 |
# show R code and debug info buttons will have already been hidden by disable_r_code |
|
| 1080 |
} |
|
| 1081 |
}) |
|
| 1082 | ||
| 1083 |
# all the inputs and data that can be out of sync with the fitted model |
|
| 1084 | ! |
mmrm_inputs_reactive <- reactive({
|
| 1085 | ! |
shinyjs::disable("button_start")
|
| 1086 | ! |
disable_r_code(TRUE) |
| 1087 | ! |
teal::validate_inputs(iv_r()) |
| 1088 | ! |
encoding_inputs <- lapply( |
| 1089 | ! |
sync_inputs, |
| 1090 | ! |
function(x) {
|
| 1091 | ! |
if (x %in% c("Ref", "Comp")) {
|
| 1092 | ! |
unlist(input$buckets[[x]]) |
| 1093 |
} else {
|
|
| 1094 | ! |
input[[x]] |
| 1095 |
} |
|
| 1096 |
} |
|
| 1097 |
) |
|
| 1098 | ! |
names(encoding_inputs) <- sync_inputs |
| 1099 | ||
| 1100 | ! |
adsl_filtered <- anl_q()[["ADSL"]] |
| 1101 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 1102 | ||
| 1103 | ! |
teal::validate_has_data(adsl_filtered, min_nrow = 1) |
| 1104 | ! |
teal::validate_has_data(anl_filtered, min_nrow = 1) |
| 1105 | ! |
validate_checks() |
| 1106 | ! |
c(list(adsl_filtered = adsl_filtered, anl_filtered = anl_filtered), encoding_inputs) |
| 1107 |
}) |
|
| 1108 | ||
| 1109 | ! |
output$null_input_msg <- renderText({
|
| 1110 | ! |
mmrm_inputs_reactive() |
| 1111 | ! |
paste( |
| 1112 | ! |
"Please first specify 'Model Settings' and press 'Fit Model'.", |
| 1113 | ! |
"Afterwards choose 'Output Type' and optional 'Output Settings'.", |
| 1114 | ! |
"If changes to the 'Model Settings' or dataset (by filtering) are made,", |
| 1115 | ! |
"then the 'Fit Model' button must be pressed again to update the MMRM model.", |
| 1116 | ! |
"Note that the 'Show R Code' button can only be clicked if the model fit is up to date." |
| 1117 |
) |
|
| 1118 |
}) |
|
| 1119 | ||
| 1120 |
# compares the mmrm_inputs_reactive values with the values stored in 'state' |
|
| 1121 | ! |
state_has_changed <- reactive({
|
| 1122 | ! |
req(state$input) |
| 1123 | ! |
displayed_state <- mmrm_inputs_reactive() |
| 1124 | ! |
equal_ADSL <- all.equal(state$input$adsl_filtered, displayed_state$adsl_filtered) # nolint: object_name. |
| 1125 | ! |
equal_dataname <- all.equal(state$input$anl_filtered, displayed_state$anl_filtered) |
| 1126 | ! |
true_means_change <- vapply( |
| 1127 | ! |
sync_inputs, |
| 1128 | ! |
FUN = function(x) {
|
| 1129 | ! |
if (is.null(state$input[[x]])) {
|
| 1130 | ! |
if (is.null(displayed_state[[x]])) {
|
| 1131 | ! |
return(FALSE) |
| 1132 |
} else {
|
|
| 1133 | ! |
return(TRUE) |
| 1134 |
} |
|
| 1135 | ! |
} else if (is.null(displayed_state[[x]])) {
|
| 1136 | ! |
return(TRUE) |
| 1137 |
} |
|
| 1138 | ! |
if (length(state$input[[x]]) != length(displayed_state[[x]])) {
|
| 1139 | ! |
return(TRUE) |
| 1140 |
} |
|
| 1141 | ! |
any(sort(state$input[[x]]) != sort(displayed_state[[x]])) |
| 1142 |
}, |
|
| 1143 | ! |
FUN.VALUE = logical(1) |
| 1144 |
) |
|
| 1145 | ||
| 1146 |
# all.equal function either returns TRUE or a character scalar to describe where there is inequality |
|
| 1147 | ! |
any(c(is.character(equal_ADSL), is.character(equal_dataname), true_means_change)) |
| 1148 |
}) |
|
| 1149 | ||
| 1150 |
# Event handler: |
|
| 1151 |
# These trigger when we are out of sync and then enable the start button and |
|
| 1152 |
# disable the show R code button and show warning message |
|
| 1153 | ! |
observeEvent(mmrm_inputs_reactive(), {
|
| 1154 | ! |
shinyjs::enable("button_start")
|
| 1155 | ! |
disable_r_code(TRUE) |
| 1156 | ! |
if (!state_has_changed()) {
|
| 1157 | ! |
disable_r_code(FALSE) |
| 1158 | ! |
shinyjs::disable("button_start")
|
| 1159 |
} |
|
| 1160 |
}) |
|
| 1161 | ||
| 1162 |
# Prepare the analysis environment (filter data, check data, populate envir). |
|
| 1163 | ! |
validate_checks <- reactive({
|
| 1164 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 1165 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 1166 | ! |
anl_data <- anl_q()[["ANL"]] |
| 1167 | ||
| 1168 | ! |
anl_m_inputs <- anl_inputs() |
| 1169 | ! |
if (!is.null(input[[extract_input("arm_var", parentname)]])) {
|
| 1170 | ! |
input_arm_var <- as.vector(anl_m_inputs$columns_source$arm_var) |
| 1171 |
} else {
|
|
| 1172 | ! |
input_arm_var <- NULL |
| 1173 |
} |
|
| 1174 | ! |
input_visit_var <- as.vector(anl_m_inputs$columns_source$visit_var) |
| 1175 | ||
| 1176 | ! |
input_aval_var <- as.vector(anl_m_inputs$columns_source$aval_var) |
| 1177 | ! |
input_id_var <- as.vector(anl_m_inputs$columns_source$id_var) |
| 1178 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 1179 | ||
| 1180 |
# Split the existing covariate strings in their variable parts, to allow "A*B" and "A:B" notations. |
|
| 1181 | ! |
input_cov_var <- as.vector(anl_m_inputs$columns_source$split_covariates) |
| 1182 | ! |
covariate_parts <- split_interactions(input_cov_var) |
| 1183 | ||
| 1184 | ! |
all_x_vars <- c(input_arm_var, input_visit_var, covariate_parts) |
| 1185 | ||
| 1186 | ! |
all_x_vars_in_adsl <- intersect( |
| 1187 | ! |
all_x_vars, |
| 1188 | ! |
colnames(adsl_filtered) |
| 1189 |
) |
|
| 1190 | ! |
all_x_vars_in_anl <- setdiff( |
| 1191 | ! |
all_x_vars, |
| 1192 | ! |
all_x_vars_in_adsl |
| 1193 |
) |
|
| 1194 | ||
| 1195 | ! |
adslvars <- unique(c("USUBJID", "STUDYID", input_arm_var, input_id_var, all_x_vars_in_adsl))
|
| 1196 | ! |
anlvars <- unique(c("USUBJID", "STUDYID", input_paramcd, input_aval_var, input_visit_var, all_x_vars_in_anl))
|
| 1197 | ||
| 1198 | ! |
validate_standard_inputs( |
| 1199 | ! |
adsl = adsl_filtered, |
| 1200 | ! |
adslvars = adslvars, |
| 1201 | ! |
anl = anl_filtered, |
| 1202 | ! |
anlvars = anlvars, |
| 1203 | ! |
arm_var = input_arm_var, |
| 1204 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 1205 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 1206 | ! |
min_nrow = 10, |
| 1207 | ! |
need_arm = FALSE |
| 1208 |
) |
|
| 1209 | ||
| 1210 | ! |
Map( |
| 1211 | ! |
function(visit_df, visit_name) {
|
| 1212 | ! |
dup <- any(duplicated(visit_df[[input_id_var]])) |
| 1213 | ! |
validate(need(!dup, paste("Duplicated subject ID found at", visit_name)))
|
| 1214 |
}, |
|
| 1215 | ! |
split(anl_data, anl_data[[input_visit_var]]), |
| 1216 | ! |
levels(anl_data[[input_visit_var]]) |
| 1217 |
) |
|
| 1218 |
}) |
|
| 1219 | ||
| 1220 |
# Connector: |
|
| 1221 |
# Fit the MMRM, once the user clicks on the start button. |
|
| 1222 | ! |
mmrm_fit <- eventReactive(input$button_start, {
|
| 1223 | ! |
qenv <- anl_q() |
| 1224 | ! |
anl_m_inputs <- anl_inputs() |
| 1225 | ||
| 1226 | ! |
my_calls <- template_fit_mmrm( |
| 1227 | ! |
parentname = "ANL_ADSL", |
| 1228 | ! |
dataname = "ANL", |
| 1229 | ! |
aval_var = as.vector(anl_m_inputs$columns_source$aval_var), |
| 1230 | ! |
arm_var = input[[extract_input("arm_var", parentname)]],
|
| 1231 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 1232 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 1233 | ! |
combine_comp_arms = input$combine_comp_arms, |
| 1234 | ! |
id_var = as.vector(anl_m_inputs$columns_source$id_var), |
| 1235 | ! |
visit_var = as.vector(anl_m_inputs$columns_source$visit_var), |
| 1236 | ! |
cov_var = input[[extract_input("cov_var", dataname)]],
|
| 1237 | ! |
conf_level = as.numeric(input$conf_level), |
| 1238 | ! |
method = as.character(input$method), |
| 1239 | ! |
cor_struct = input$cor_struct, |
| 1240 | ! |
weights_emmeans = input$weights_emmeans, |
| 1241 | ! |
parallel = input$parallel |
| 1242 |
) |
|
| 1243 | ! |
teal.code::eval_code(qenv, as.expression(my_calls)) |
| 1244 |
}) |
|
| 1245 | ||
| 1246 | ! |
output$mmrm_title <- renderText({
|
| 1247 | ! |
new_inputs <- try(state_has_changed(), silent = TRUE) |
| 1248 |
# No message needed here because it will be displayed by either plots or tables output |
|
| 1249 | ! |
validate(need(!inherits(new_inputs, "try-error") && !new_inputs, character(0))) |
| 1250 | ||
| 1251 |
# Input on output type. |
|
| 1252 | ! |
output_function <- input$output_function |
| 1253 | ! |
g_mmrm_diagnostic_type <- input$g_mmrm_diagnostic_type |
| 1254 | ! |
g_mmrm_lsmeans_select <- input$g_mmrm_lsmeans_select |
| 1255 | ||
| 1256 | ! |
output_title <- switch(output_function, |
| 1257 | ! |
"t_mmrm_cov" = "Residual Covariance Matrix Estimate", |
| 1258 | ! |
"t_mmrm_diagnostic" = "Model Fit Statistics", |
| 1259 | ! |
"t_mmrm_fixed" = "Fixed Effects Estimates", |
| 1260 | ! |
"t_mmrm_lsmeans" = "LS Means and Contrasts Estimates", |
| 1261 | ! |
"g_mmrm_diagnostic" = switch(g_mmrm_diagnostic_type, |
| 1262 | ! |
"fit-residual" = "Marginal Fitted Values vs. Residuals", |
| 1263 | ! |
"q-q-residual" = "Q-Q Normal Plot for Standardized Residuals" |
| 1264 |
), |
|
| 1265 | ! |
"g_mmrm_lsmeans" = if (setequal(g_mmrm_lsmeans_select, c("estimates", "contrasts"))) {
|
| 1266 | ! |
"LS Means Estimates and Contrasts" |
| 1267 | ! |
} else if (identical(g_mmrm_lsmeans_select, "estimates")) {
|
| 1268 | ! |
"LS Means Estimates" |
| 1269 |
} else {
|
|
| 1270 | ! |
"LS Means Contrasts" |
| 1271 |
} |
|
| 1272 |
) |
|
| 1273 | ! |
output_title |
| 1274 |
}) |
|
| 1275 | ||
| 1276 | ! |
table_q <- reactive({
|
| 1277 | ! |
validate( |
| 1278 | ! |
need( |
| 1279 | ! |
!state_has_changed(), |
| 1280 | ! |
"Inputs changed and no longer reflect the fitted model. Press `Fit Model` button again to re-fit model." |
| 1281 |
) |
|
| 1282 |
) |
|
| 1283 |
# Input on output type. |
|
| 1284 | ! |
output_function <- input$output_function |
| 1285 | ||
| 1286 |
# If the output is not a table, stop here. |
|
| 1287 | ! |
if (!isTRUE(grepl("^t_", output_function))) {
|
| 1288 | ! |
return(NULL) |
| 1289 |
} |
|
| 1290 |
# Get the fit stack while evaluating the fit code at the same time. |
|
| 1291 | ! |
qenv <- mmrm_fit() |
| 1292 | ! |
fit <- qenv[["fit"]] |
| 1293 | ||
| 1294 | ! |
anl_m_inputs <- anl_inputs() |
| 1295 | ||
| 1296 | ! |
ANL <- qenv[["ANL"]] |
| 1297 | ! |
ANL_ADSL <- qenv[["ANL_ADSL"]] |
| 1298 | ! |
paramcd <- unique(ANL[[unlist(paramcd$filter)["vars_selected"]]]) |
| 1299 | ||
| 1300 | ! |
basic_table_args$subtitles <- paste0( |
| 1301 | ! |
"Analysis Variable: ", anl_m_inputs$columns_source$aval_var, |
| 1302 | ! |
", Endpoint: ", anl_m_inputs$filter_info$paramcd[[1]]$selected[[1]], |
| 1303 | ! |
ifelse(is.null(fit$vars$covariates), "", paste(", Covariates:", paste(fit$vars$covariates, collapse = ", ")))
|
| 1304 |
) |
|
| 1305 | ! |
basic_table_args$main_footer <- c( |
| 1306 | ! |
paste("Weights for LS Means:", input$weights_emmeans),
|
| 1307 | ! |
paste("Correlation Structure:", input$cor_struct),
|
| 1308 | ! |
paste("Adjustment Method:", input$method)
|
| 1309 |
) |
|
| 1310 | ||
| 1311 | ! |
mmrm_table <- template_mmrm_tables( |
| 1312 | ! |
parentname = "ANL_ADSL", |
| 1313 | ! |
dataname = "ANL", |
| 1314 | ! |
fit_name = "fit", |
| 1315 | ! |
arm_var = input[[extract_input("arm_var", parentname)]],
|
| 1316 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 1317 | ! |
visit_var = as.vector(anl_m_inputs$columns_source$visit_var), |
| 1318 | ! |
paramcd = paramcd, |
| 1319 | ! |
show_relative = input$t_mmrm_lsmeans_show_relative, |
| 1320 | ! |
table_type = output_function, |
| 1321 | ! |
total_label = total_label, |
| 1322 | ! |
basic_table_args = basic_table_args |
| 1323 |
) |
|
| 1324 | ||
| 1325 | ! |
teal.code::eval_code(qenv, as.expression(mmrm_table)) |
| 1326 |
}) |
|
| 1327 | ||
| 1328 |
# Endpoint: |
|
| 1329 |
# Plot outputs. |
|
| 1330 | ! |
plot_q <- reactive({
|
| 1331 | ! |
validate( |
| 1332 | ! |
need( |
| 1333 | ! |
!state_has_changed(), |
| 1334 | ! |
"Inputs changed and no longer reflect the fitted model. Press `Fit Model` button again to re-fit model." |
| 1335 |
) |
|
| 1336 |
) |
|
| 1337 |
# Input on output type. |
|
| 1338 | ! |
output_function <- input$output_function |
| 1339 | ||
| 1340 |
# Stop here if the output is not a plot. |
|
| 1341 | ! |
if (!isTRUE(grepl("^g_", output_function))) {
|
| 1342 | ! |
return(NULL) |
| 1343 |
} |
|
| 1344 | ||
| 1345 | ! |
qenv <- mmrm_fit() |
| 1346 | ! |
fit <- qenv[["fit"]] |
| 1347 | ||
| 1348 | ! |
ggplot2_args[["lsmeans"]] <- teal.widgets::ggplot2_args( |
| 1349 | ! |
labs <- list( |
| 1350 | ! |
subtitle = paste0( |
| 1351 | ! |
"Endpoint: ", fit$fit$data$PARAMCD[1], |
| 1352 | ! |
ifelse(is.null(fit$vars$covariates), "", |
| 1353 | ! |
paste(", Covariates:", paste(fit$vars$covariates, collapse = ", "))
|
| 1354 |
) |
|
| 1355 |
), |
|
| 1356 | ! |
caption = paste( |
| 1357 | ! |
paste("Weights for LS Means:", input$weights_emmeans),
|
| 1358 | ! |
paste("Correlation Structure:", input$cor_struct),
|
| 1359 | ! |
paste("Adjustment Method:", input$method),
|
| 1360 | ! |
sep = "\n" |
| 1361 |
) |
|
| 1362 |
) |
|
| 1363 |
) |
|
| 1364 | ||
| 1365 | ! |
ggplot2_args[["default"]] <- teal.widgets::ggplot2_args( |
| 1366 | ! |
labs <- list( |
| 1367 | ! |
subtitle = paste0( |
| 1368 | ! |
"Analysis Variable: ", fit$vars$response, |
| 1369 | ! |
", Endpoint: ", fit$fit$data$PARAMCD[1] |
| 1370 |
) |
|
| 1371 |
) |
|
| 1372 |
) |
|
| 1373 | ||
| 1374 | ! |
lsmeans_args <- if (output_function == "g_mmrm_lsmeans") {
|
| 1375 | ! |
list( |
| 1376 | ! |
select = input$g_mmrm_lsmeans_select, |
| 1377 | ! |
width = input$g_mmrm_lsmeans_width, |
| 1378 | ! |
show_pval = input$g_mmrm_lsmeans_contrasts_show_pval |
| 1379 |
) |
|
| 1380 |
} |
|
| 1381 | ||
| 1382 | ! |
diagnostic_args <- if (output_function == "g_mmrm_diagnostic") {
|
| 1383 | ! |
list( |
| 1384 | ! |
type = input$g_mmrm_diagnostic_type, |
| 1385 | ! |
z_threshold = input$g_mmrm_diagnostic_z_threshold |
| 1386 |
) |
|
| 1387 |
} |
|
| 1388 | ||
| 1389 | ! |
mmrm_plot_expr <- template_mmrm_plots( |
| 1390 | ! |
fit_name = "fit", |
| 1391 | ! |
lsmeans_plot = lsmeans_args, |
| 1392 | ! |
diagnostic_plot = diagnostic_args, |
| 1393 | ! |
ggplot2_args = ggplot2_args |
| 1394 |
) |
|
| 1395 | ! |
teal.code::eval_code(qenv, as.expression(mmrm_plot_expr)) |
| 1396 |
}) |
|
| 1397 | ||
| 1398 | ! |
all_q <- reactive({
|
| 1399 | ! |
if (!is.null(plot_q()) && !is.null(table_q())) {
|
| 1400 | ! |
teal.code::join(plot_q(), table_q()) |
| 1401 | ! |
} else if (!is.null(plot_q())) {
|
| 1402 | ! |
plot_q() |
| 1403 |
} else {
|
|
| 1404 | ! |
table_q() |
| 1405 |
} |
|
| 1406 |
}) |
|
| 1407 | ||
| 1408 | ! |
table_r <- reactive({
|
| 1409 | ! |
switch(input$output_function, |
| 1410 | ! |
t_mmrm_lsmeans = table_q()[["lsmeans_table"]], |
| 1411 | ! |
t_mmrm_diagnostic = table_q()[["diagnostic_table"]], |
| 1412 | ! |
t_mmrm_fixed = table_q()[["fixed_effects"]], |
| 1413 | ! |
t_mmrm_cov = table_q()[["cov_matrix"]] |
| 1414 |
) |
|
| 1415 |
}) |
|
| 1416 | ||
| 1417 | ! |
plot_r <- reactive({
|
| 1418 | ! |
switch(input$output_function, |
| 1419 | ! |
g_mmrm_lsmeans = plot_q()[["lsmeans_plot"]], |
| 1420 | ! |
g_mmrm_diagnostic = plot_q()[["diagnostic_plot"]] |
| 1421 |
) |
|
| 1422 |
}) |
|
| 1423 | ||
| 1424 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 1425 | ! |
id = "mmrm_plot", |
| 1426 | ! |
plot_r = plot_r, |
| 1427 | ! |
height = plot_height, |
| 1428 | ! |
width = plot_width, |
| 1429 | ! |
show_hide_signal = reactive(show_plot_rv()) |
| 1430 |
) |
|
| 1431 | ||
| 1432 | ! |
teal.widgets::table_with_settings_srv( |
| 1433 | ! |
id = "mmrm_table", |
| 1434 | ! |
table_r = table_r, |
| 1435 | ! |
show_hide_signal = reactive(!show_plot_rv()) |
| 1436 |
) |
|
| 1437 | ||
| 1438 |
# Show R code once button is pressed. |
|
| 1439 | ! |
teal.widgets::verbatim_popup_srv( |
| 1440 | ! |
id = "rcode", |
| 1441 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 1442 | ! |
disabled = disable_r_code, |
| 1443 | ! |
title = "R Code for the Current MMRM Analysis" |
| 1444 |
) |
|
| 1445 | ||
| 1446 |
### REPORTER |
|
| 1447 | ! |
if (with_reporter) {
|
| 1448 | ! |
card_fun <- function(comment, label) {
|
| 1449 | ! |
card <- teal::report_card_template( |
| 1450 | ! |
title = "Mixed Model Repeated Measurements (MMRM) Analysis", |
| 1451 | ! |
label = label, |
| 1452 | ! |
description = paste( |
| 1453 | ! |
"Mixed Models procedure analyzes results from repeated measures designs", |
| 1454 | ! |
"in which the outcome is continuous and measured at fixed time points" |
| 1455 |
), |
|
| 1456 | ! |
with_filter = with_filter, |
| 1457 | ! |
filter_panel_api = filter_panel_api |
| 1458 |
) |
|
| 1459 | ! |
if (!is.null(table_r())) {
|
| 1460 | ! |
card$append_text("Table", "header3")
|
| 1461 | ! |
card$append_table(table_r()) |
| 1462 |
} |
|
| 1463 | ! |
if (!is.null(plot_r())) {
|
| 1464 | ! |
card$append_text("Plot", "header3")
|
| 1465 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 1466 |
} |
|
| 1467 | ! |
if (!comment == "") {
|
| 1468 | ! |
card$append_text("Comment", "header3")
|
| 1469 | ! |
card$append_text(comment) |
| 1470 |
} |
|
| 1471 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 1472 | ! |
card |
| 1473 |
} |
|
| 1474 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1475 |
} |
|
| 1476 |
### |
|
| 1477 |
}) |
|
| 1478 |
} |
| 1 |
#' Template: Patient Profile Therapy Table and Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a patient profile therapy table and [ggplot2::ggplot()] plot using ADaM |
|
| 4 |
#' datasets. |
|
| 5 |
#' |
|
| 6 |
#' @inheritParams template_arguments |
|
| 7 |
#' @param cmdose (`character`)\cr name of dose per administration variable. |
|
| 8 |
#' @param cmtrt (`character`)\cr name of reported name of drug, med, or therapy variable. |
|
| 9 |
#' @param cmdosu (`character`)\cr name of dose units variable. |
|
| 10 |
#' @param cmroute (`character`)\cr name of route of administration variable. |
|
| 11 |
#' @param cmdosfrq (`character`)\cr name of dosing frequency per interval variable. |
|
| 12 |
#' @param cmendy (`character`)\cr name of study day of end of medication variable. |
|
| 13 |
#' |
|
| 14 |
#' @inherit template_arguments return |
|
| 15 |
#' |
|
| 16 |
#' @seealso [tm_g_pp_therapy()] |
|
| 17 |
#' |
|
| 18 |
#' @keywords internal |
|
| 19 |
template_therapy <- function(dataname = "ANL", |
|
| 20 |
atirel = "ATIREL", |
|
| 21 |
cmdecod = "CMDECOD", |
|
| 22 |
cmindc = "CMINDC", |
|
| 23 |
cmdose = "CMDOSE", |
|
| 24 |
cmtrt = "CMTRT", |
|
| 25 |
cmdosu = "CMDOSU", |
|
| 26 |
cmroute = "CMROUTE", |
|
| 27 |
cmdosfrq = "CMDOSFRQ", |
|
| 28 |
cmstdy = "CMSTDY", |
|
| 29 |
cmendy = "CMENDY", |
|
| 30 |
patient_id, |
|
| 31 |
font_size = 12L, |
|
| 32 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 33 | ! |
checkmate::assert_string(dataname) |
| 34 | ! |
checkmate::assert_string(atirel) |
| 35 | ! |
checkmate::assert_string(cmdecod) |
| 36 | ! |
checkmate::assert_string(cmindc) |
| 37 | ! |
checkmate::assert_string(cmdose) |
| 38 | ! |
checkmate::assert_string(cmtrt) |
| 39 | ! |
checkmate::assert_string(cmdosu) |
| 40 | ! |
checkmate::assert_string(cmroute) |
| 41 | ! |
checkmate::assert_string(cmdosfrq) |
| 42 | ! |
checkmate::assert_string(cmstdy) |
| 43 | ! |
checkmate::assert_string(cmendy) |
| 44 | ! |
checkmate::assert_string(patient_id) |
| 45 | ! |
checkmate::assert_number(font_size) |
| 46 | ||
| 47 | ! |
y <- list() |
| 48 | ! |
y$table_list <- list() |
| 49 | ! |
y$plot_list <- list() |
| 50 | ||
| 51 | ! |
table_list <- add_expr( |
| 52 | ! |
list(), |
| 53 | ! |
substitute(expr = {
|
| 54 | ! |
cols_to_include <- c( |
| 55 | ! |
cmindc_char, |
| 56 | ! |
cmdecod_char, |
| 57 | ! |
cmdose_char, |
| 58 | ! |
cmtrt_char, |
| 59 | ! |
cmdosu_char, |
| 60 | ! |
cmroute_char, |
| 61 | ! |
cmdosfrq_char, |
| 62 | ! |
cmstdy_char, |
| 63 | ! |
cmendy_char |
| 64 |
) |
|
| 65 | ||
| 66 | ! |
dataname[setdiff(cols_to_include, names(dataname))] <- NA |
| 67 | ||
| 68 | ! |
therapy_table <- dataname %>% |
| 69 | ! |
dplyr::filter(atirel %in% c("CONCOMITANT", "PRIOR")) %>% # removed PRIOR_CONCOMITANT
|
| 70 | ! |
dplyr::select(dplyr::all_of(cols_to_include)) %>% |
| 71 | ! |
dplyr::filter(!is.na(cmdecod)) %>% |
| 72 | ! |
dplyr::mutate(Dosage = paste(cmdose, cmdosu, cmdosfrq, cmroute)) %>% |
| 73 | ! |
dplyr::select(-cmdose, -cmdosu, -cmdosfrq, -cmroute) %>% |
| 74 | ! |
dplyr::select(cmindc, cmdecod, Dosage, dplyr::everything()) %>% |
| 75 | ! |
dplyr::mutate(!!cmdecod_char := dplyr::case_when( |
| 76 | ! |
nchar(as.character(cmdecod)) > 20 ~ as.character(cmtrt), |
| 77 | ! |
TRUE ~ as.character(cmdecod) |
| 78 |
)) %>% |
|
| 79 | ! |
dplyr::select(-cmtrt) %>% |
| 80 | ! |
dplyr::arrange(cmindc, cmdecod, cmstdy) %>% |
| 81 | ! |
dplyr::distinct() %>% |
| 82 | ! |
`colnames<-`(c( |
| 83 | ! |
col_labels(dataname, fill = TRUE)[c(cmindc_char, cmdecod_char)], "Dosage", |
| 84 | ! |
col_labels(dataname, fill = TRUE)[c(cmstdy_char, cmendy_char)] |
| 85 |
)) |
|
| 86 | ||
| 87 | ! |
therapy_table <- rlistings::as_listing( |
| 88 | ! |
therapy_table, |
| 89 | ! |
key_cols = NULL, |
| 90 | ! |
default_formatting = list(all = fmt_config(align = "left")) |
| 91 |
) |
|
| 92 | ! |
main_title(therapy_table) <- paste("Patient ID:", patient_id)
|
| 93 | ||
| 94 | ! |
therapy_table |
| 95 | ! |
}, env = list( |
| 96 | ! |
dataname = as.name(dataname), |
| 97 | ! |
atirel = as.name(atirel), |
| 98 | ! |
cmdecod = as.name(cmdecod), |
| 99 | ! |
cmindc = as.name(cmindc), |
| 100 | ! |
cmdose = as.name(cmdose), |
| 101 | ! |
cmtrt = as.name(cmtrt), |
| 102 | ! |
cmdosu = as.name(cmdosu), |
| 103 | ! |
cmroute = as.name(cmroute), |
| 104 | ! |
cmdosfrq = as.name(cmdosfrq), |
| 105 | ! |
cmstdy = as.name(cmstdy), |
| 106 | ! |
cmendy = as.name(cmendy), |
| 107 | ! |
cmdecod_char = cmdecod, |
| 108 | ! |
cmindc_char = cmindc, |
| 109 | ! |
cmdose_char = cmdose, |
| 110 | ! |
cmtrt_char = cmtrt, |
| 111 | ! |
cmdosu_char = cmdosu, |
| 112 | ! |
cmroute_char = cmroute, |
| 113 | ! |
cmdosfrq_char = cmdosfrq, |
| 114 | ! |
cmendy_char = cmendy, |
| 115 | ! |
cmstdy_char = cmstdy, |
| 116 | ! |
patient_id = patient_id |
| 117 |
)) |
|
| 118 |
) |
|
| 119 | ||
| 120 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 121 | ! |
teal.widgets::resolve_ggplot2_args( |
| 122 | ! |
user_plot = ggplot2_args, |
| 123 | ! |
module_plot = teal.widgets::ggplot2_args( |
| 124 | ! |
labs = list(y = "Medication", title = paste0("Patient ID: ", patient_id)),
|
| 125 | ! |
theme = list( |
| 126 | ! |
text = substitute(ggplot2::element_text(size = font), list(font = font_size)), |
| 127 | ! |
axis.text.y = quote(ggplot2::element_blank()), |
| 128 | ! |
axis.ticks.y = quote(ggplot2::element_blank()), |
| 129 | ! |
plot.title = substitute(ggplot2::element_text(size = font), list(font = font_size)), |
| 130 | ! |
legend.position = "none", |
| 131 | ! |
panel.grid.minor = quote(ggplot2::element_line( |
| 132 | ! |
linewidth = 0.5, |
| 133 | ! |
linetype = "dotted", |
| 134 | ! |
colour = "grey" |
| 135 |
)), |
|
| 136 | ! |
panel.grid.major = quote(ggplot2::element_line( |
| 137 | ! |
linewidth = 0.5, |
| 138 | ! |
linetype = "dotted", |
| 139 | ! |
colour = "grey" |
| 140 |
)) |
|
| 141 |
) |
|
| 142 |
) |
|
| 143 |
), |
|
| 144 | ! |
ggtheme = "minimal" |
| 145 |
) |
|
| 146 | ||
| 147 | ! |
plot_list <- add_expr( |
| 148 | ! |
list(), |
| 149 | ! |
substitute(expr = {
|
| 150 | ! |
dataname[[cmstdy_char]] <- as.numeric(dataname[[cmstdy_char]]) |
| 151 | ! |
dataname[[cmendy_char]] <- as.numeric(dataname[[cmendy_char]]) |
| 152 | ! |
max_day <- max(dataname[[cmendy_char]], na.rm = TRUE) |
| 153 | ! |
data <- dataname %>% |
| 154 | ! |
dplyr::filter(atirel %in% c("CONCOMITANT", "PRIOR")) %>% # remove PRIOR_CONCOMITANT
|
| 155 | ! |
dplyr::select_at(cols_to_include) %>% |
| 156 | ! |
dplyr::filter(!is.na(cmdecod)) %>% |
| 157 | ! |
dplyr::mutate(DOSE = paste(cmdose, cmdosu, cmdosfrq)) %>% |
| 158 | ! |
dplyr::select(-cmdose, -cmdosu, -cmdosfrq) %>% |
| 159 | ! |
dplyr::select(cmindc, cmdecod, DOSE, dplyr::everything()) %>% |
| 160 | ! |
dplyr::arrange(cmindc, cmdecod, cmstdy) %>% |
| 161 | ! |
dplyr::distinct() %>% |
| 162 | ! |
dplyr::mutate(CMSTDY = dplyr::case_when( |
| 163 | ! |
is.na(cmstdy) ~ 1, |
| 164 | ! |
TRUE ~ cmstdy |
| 165 |
)) %>% |
|
| 166 | ! |
dplyr::mutate(CMENDY = dplyr::case_when( |
| 167 | ! |
is.na(cmendy) ~ max_day, |
| 168 | ! |
TRUE ~ cmendy |
| 169 |
)) %>% |
|
| 170 | ! |
dplyr::arrange(CMSTDY, dplyr::desc(CMSTDY)) %>% |
| 171 | ! |
dplyr::mutate(CMDECOD = dplyr::case_when( |
| 172 | ! |
nchar(as.character(cmdecod)) > 20 ~ as.character(cmtrt), |
| 173 | ! |
TRUE ~ as.character(cmdecod) |
| 174 |
)) |
|
| 175 | ||
| 176 | ! |
therapy_plot <- |
| 177 | ! |
ggplot2::ggplot(data = data, ggplot2::aes(fill = cmindc, color = cmindc, y = CMDECOD, x = CMSTDY)) + |
| 178 | ! |
ggplot2::geom_segment(ggplot2::aes(xend = CMENDY, yend = CMDECOD), size = 2) + |
| 179 | ! |
ggplot2::geom_text( |
| 180 | ! |
data = data %>% |
| 181 | ! |
dplyr::select(CMDECOD, cmindc, CMSTDY) %>% |
| 182 | ! |
dplyr::distinct(), |
| 183 | ! |
ggplot2::aes(x = CMSTDY, label = CMDECOD), color = "black", |
| 184 | ! |
hjust = "left", |
| 185 | ! |
vjust = "bottom", |
| 186 | ! |
nudge_y = 0.1, |
| 187 | ! |
size = font_size_var / 3.5 |
| 188 |
) + |
|
| 189 | ! |
ggplot2::scale_y_discrete(expand = ggplot2::expansion(add = 1.2)) + |
| 190 | ! |
ggplot2::geom_point(color = "black", size = 2, shape = 24, position = ggplot2::position_nudge(y = -0.15)) + |
| 191 | ! |
labs + |
| 192 | ! |
ggtheme + |
| 193 | ! |
theme |
| 194 | ||
| 195 | ! |
print(therapy_plot) |
| 196 | ! |
}, env = c( |
| 197 | ! |
list( |
| 198 | ! |
dataname = as.name(dataname), |
| 199 | ! |
atirel = as.name(atirel), |
| 200 | ! |
cmdecod = as.name(cmdecod), |
| 201 | ! |
cmindc = as.name(cmindc), |
| 202 | ! |
cmdose = as.name(cmdose), |
| 203 | ! |
cmtrt = as.name(cmtrt), |
| 204 | ! |
cmdosu = as.name(cmdosu), |
| 205 | ! |
cmroute = as.name(cmroute), |
| 206 | ! |
cmdosfrq = as.name(cmdosfrq), |
| 207 | ! |
cmstdy = as.name(cmstdy), |
| 208 | ! |
cmendy = as.name(cmendy), |
| 209 | ! |
cmdecod_char = cmdecod, |
| 210 | ! |
cmindc_char = cmindc, |
| 211 | ! |
cmdose_char = cmdose, |
| 212 | ! |
cmtrt_char = cmtrt, |
| 213 | ! |
cmdosu_char = cmdosu, |
| 214 | ! |
cmroute_char = cmroute, |
| 215 | ! |
cmdosfrq_char = cmdosfrq, |
| 216 | ! |
cmstdy_char = cmstdy, |
| 217 | ! |
cmendy_char = cmendy, |
| 218 | ! |
patient_id = patient_id, |
| 219 | ! |
font_size_var = font_size |
| 220 |
), |
|
| 221 | ! |
parsed_ggplot2_args |
| 222 |
)) |
|
| 223 |
) |
|
| 224 | ! |
y$table_list <- bracket_expr(table_list) |
| 225 | ! |
y$plot_list <- bracket_expr(plot_list) |
| 226 | ! |
y |
| 227 |
} |
|
| 228 | ||
| 229 |
#' teal Module: Patient Profile Therapy Table and Plot |
|
| 230 |
#' |
|
| 231 |
#' This module produces a patient profile therapy table and [ggplot2::ggplot()] type plot using ADaM datasets. |
|
| 232 |
#' |
|
| 233 |
#' @inheritParams module_arguments |
|
| 234 |
#' @inheritParams template_therapy |
|
| 235 |
#' @param cmdose ([teal.transform::choices_selected()])\cr object with all |
|
| 236 |
#' available choices and preselected option for the `CMDOSE` variable from `dataname`. |
|
| 237 |
#' @param cmtrt ([teal.transform::choices_selected()])\cr object with all |
|
| 238 |
#' available choices and preselected option for the `CMTRT` variable from `dataname`. |
|
| 239 |
#' @param cmdosu ([teal.transform::choices_selected()])\cr object with all |
|
| 240 |
#' available choices and preselected option for the `CMDOSU` variable from `dataname`. |
|
| 241 |
#' @param cmroute ([teal.transform::choices_selected()])\cr object with all |
|
| 242 |
#' available choices and preselected option for the `CMROUTE` variable from `dataname`. |
|
| 243 |
#' @param cmdosfrq ([teal.transform::choices_selected()])\cr object with all |
|
| 244 |
#' available choices and preselected option for the `CMDOSFRQ` variable from `dataname`. |
|
| 245 |
#' @param cmendy ([teal.transform::choices_selected()])\cr object with all |
|
| 246 |
#' available choices and preselected option for the `CMENDY` variable from `dataname`. |
|
| 247 |
#' |
|
| 248 |
#' @inherit module_arguments return |
|
| 249 |
#' |
|
| 250 |
#' @examples |
|
| 251 |
#' library(nestcolor) |
|
| 252 |
#' library(dplyr) |
|
| 253 |
#' |
|
| 254 |
#' ADCM <- tmc_ex_adcm |
|
| 255 |
#' ADSL <- tmc_ex_adsl %>% filter(USUBJID %in% ADCM$USUBJID) |
|
| 256 |
#' ADCM$CMASTDTM <- ADCM$ASTDTM |
|
| 257 |
#' ADCM$CMAENDTM <- ADCM$AENDTM |
|
| 258 |
#' adcm_keys <- c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "ATC1", "ATC2", "ATC3", "ATC4")
|
|
| 259 |
#' |
|
| 260 |
#' join_keys <- default_cdisc_join_keys[c("ADSL", "ADCM")]
|
|
| 261 |
#' join_keys["ADCM", "ADCM"] <- adcm_keys |
|
| 262 |
#' |
|
| 263 |
#' app <- init( |
|
| 264 |
#' data = cdisc_data( |
|
| 265 |
#' ADSL = ADSL, |
|
| 266 |
#' ADCM = ADCM, |
|
| 267 |
#' code = " |
|
| 268 |
#' ADCM <- tmc_ex_adcm |
|
| 269 |
#' ADSL <- tmc_ex_adsl %>% filter(USUBJID %in% ADCM$USUBJID) |
|
| 270 |
#' ADCM$CMASTDTM <- ADCM$ASTDTM |
|
| 271 |
#' ADCM$CMAENDTM <- ADCM$AENDTM |
|
| 272 |
#' ", |
|
| 273 |
#' join_keys = join_keys |
|
| 274 |
#' ), |
|
| 275 |
#' modules = modules( |
|
| 276 |
#' tm_g_pp_therapy( |
|
| 277 |
#' label = "Therapy", |
|
| 278 |
#' dataname = "ADCM", |
|
| 279 |
#' parentname = "ADSL", |
|
| 280 |
#' patient_col = "USUBJID", |
|
| 281 |
#' plot_height = c(600L, 200L, 2000L), |
|
| 282 |
#' atirel = choices_selected( |
|
| 283 |
#' choices = variable_choices(ADCM, "ATIREL"), |
|
| 284 |
#' selected = c("ATIREL")
|
|
| 285 |
#' ), |
|
| 286 |
#' cmdecod = choices_selected( |
|
| 287 |
#' choices = variable_choices(ADCM, "CMDECOD"), |
|
| 288 |
#' selected = "CMDECOD" |
|
| 289 |
#' ), |
|
| 290 |
#' cmindc = choices_selected( |
|
| 291 |
#' choices = variable_choices(ADCM, "CMINDC"), |
|
| 292 |
#' selected = "CMINDC" |
|
| 293 |
#' ), |
|
| 294 |
#' cmdose = choices_selected( |
|
| 295 |
#' choices = variable_choices(ADCM, "CMDOSE"), |
|
| 296 |
#' selected = "CMDOSE" |
|
| 297 |
#' ), |
|
| 298 |
#' cmtrt = choices_selected( |
|
| 299 |
#' choices = variable_choices(ADCM, "CMTRT"), |
|
| 300 |
#' selected = "CMTRT" |
|
| 301 |
#' ), |
|
| 302 |
#' cmdosu = choices_selected( |
|
| 303 |
#' choices = variable_choices(ADCM, "CMDOSU"), |
|
| 304 |
#' selected = c("CMDOSU")
|
|
| 305 |
#' ), |
|
| 306 |
#' cmroute = choices_selected( |
|
| 307 |
#' choices = variable_choices(ADCM, "CMROUTE"), |
|
| 308 |
#' selected = "CMROUTE" |
|
| 309 |
#' ), |
|
| 310 |
#' cmdosfrq = choices_selected( |
|
| 311 |
#' choices = variable_choices(ADCM, "CMDOSFRQ"), |
|
| 312 |
#' selected = "CMDOSFRQ" |
|
| 313 |
#' ), |
|
| 314 |
#' cmstdy = choices_selected( |
|
| 315 |
#' choices = variable_choices(ADCM, "ASTDY"), |
|
| 316 |
#' selected = "ASTDY" |
|
| 317 |
#' ), |
|
| 318 |
#' cmendy = choices_selected( |
|
| 319 |
#' choices = variable_choices(ADCM, "AENDY"), |
|
| 320 |
#' selected = "AENDY" |
|
| 321 |
#' ) |
|
| 322 |
#' ) |
|
| 323 |
#' ) |
|
| 324 |
#' ) |
|
| 325 |
#' if (interactive()) {
|
|
| 326 |
#' shinyApp(app$ui, app$server) |
|
| 327 |
#' } |
|
| 328 |
#' |
|
| 329 |
#' @export |
|
| 330 |
tm_g_pp_therapy <- function(label, |
|
| 331 |
dataname = "ADCM", |
|
| 332 |
parentname = "ADSL", |
|
| 333 |
patient_col = "USUBJID", |
|
| 334 |
atirel = NULL, |
|
| 335 |
cmdecod = NULL, |
|
| 336 |
cmindc = NULL, |
|
| 337 |
cmdose = NULL, |
|
| 338 |
cmtrt = NULL, |
|
| 339 |
cmdosu = NULL, |
|
| 340 |
cmroute = NULL, |
|
| 341 |
cmdosfrq = NULL, |
|
| 342 |
cmstdy = NULL, |
|
| 343 |
cmendy = NULL, |
|
| 344 |
font_size = c(12L, 12L, 25L), |
|
| 345 |
plot_height = c(700L, 200L, 2000L), |
|
| 346 |
plot_width = NULL, |
|
| 347 |
pre_output = NULL, |
|
| 348 |
post_output = NULL, |
|
| 349 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 350 | ! |
message("Initializing tm_g_pp_therapy")
|
| 351 | ! |
checkmate::assert_class(atirel, "choices_selected", null.ok = TRUE) |
| 352 | ! |
checkmate::assert_class(cmdecod, "choices_selected", null.ok = TRUE) |
| 353 | ! |
checkmate::assert_class(cmindc, "choices_selected", null.ok = TRUE) |
| 354 | ! |
checkmate::assert_class(cmdose, "choices_selected", null.ok = TRUE) |
| 355 | ! |
checkmate::assert_class(cmtrt, "choices_selected", null.ok = TRUE) |
| 356 | ! |
checkmate::assert_class(cmdosu, "choices_selected", null.ok = TRUE) |
| 357 | ! |
checkmate::assert_class(cmroute, "choices_selected", null.ok = TRUE) |
| 358 | ! |
checkmate::assert_class(cmdosfrq, "choices_selected", null.ok = TRUE) |
| 359 | ! |
checkmate::assert_class(cmstdy, "choices_selected", null.ok = TRUE) |
| 360 | ! |
checkmate::assert_class(cmendy, "choices_selected", null.ok = TRUE) |
| 361 | ! |
checkmate::assert_string(label) |
| 362 | ! |
checkmate::assert_string(dataname) |
| 363 | ! |
checkmate::assert_string(parentname) |
| 364 | ! |
checkmate::assert_string(patient_col) |
| 365 | ! |
checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE) |
| 366 | ! |
checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
| 367 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 368 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 369 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 370 | ! |
checkmate::assert_numeric( |
| 371 | ! |
plot_width[1], |
| 372 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 373 |
) |
|
| 374 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 375 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 376 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 377 | ||
| 378 | ! |
args <- as.list(environment()) |
| 379 | ! |
data_extract_list <- list( |
| 380 | ! |
atirel = `if`(is.null(atirel), NULL, cs_to_des_select(atirel, dataname = dataname)), |
| 381 | ! |
cmdecod = `if`(is.null(cmdecod), NULL, cs_to_des_select(cmdecod, dataname = dataname)), |
| 382 | ! |
cmindc = `if`(is.null(cmindc), NULL, cs_to_des_select(cmindc, dataname = dataname)), |
| 383 | ! |
cmdose = `if`(is.null(cmdose), NULL, cs_to_des_select(cmdose, dataname = dataname)), |
| 384 | ! |
cmtrt = `if`(is.null(cmtrt), NULL, cs_to_des_select(cmtrt, dataname = dataname)), |
| 385 | ! |
cmdosu = `if`(is.null(cmdosu), NULL, cs_to_des_select(cmdosu, dataname = dataname)), |
| 386 | ! |
cmdosfrq = `if`(is.null(cmdosfrq), NULL, cs_to_des_select(cmdosfrq, dataname = dataname)), |
| 387 | ! |
cmroute = `if`(is.null(cmroute), NULL, cs_to_des_select(cmroute, dataname = dataname)), |
| 388 | ! |
cmstdy = `if`(is.null(cmstdy), NULL, cs_to_des_select(cmstdy, dataname = dataname)), |
| 389 | ! |
cmendy = `if`(is.null(cmendy), NULL, cs_to_des_select(cmendy, dataname = dataname)) |
| 390 |
) |
|
| 391 | ||
| 392 | ! |
module( |
| 393 | ! |
label = label, |
| 394 | ! |
ui = ui_g_therapy, |
| 395 | ! |
ui_args = c(data_extract_list, args), |
| 396 | ! |
server = srv_g_therapy, |
| 397 | ! |
server_args = c( |
| 398 | ! |
data_extract_list, |
| 399 | ! |
list( |
| 400 | ! |
dataname = dataname, |
| 401 | ! |
parentname = parentname, |
| 402 | ! |
label = label, |
| 403 | ! |
patient_col = patient_col, |
| 404 | ! |
plot_height = plot_height, |
| 405 | ! |
plot_width = plot_width, |
| 406 | ! |
ggplot2_args = ggplot2_args |
| 407 |
) |
|
| 408 |
), |
|
| 409 | ! |
datanames = c(dataname, parentname) |
| 410 |
) |
|
| 411 |
} |
|
| 412 | ||
| 413 |
#' @keywords internal |
|
| 414 |
ui_g_therapy <- function(id, ...) {
|
|
| 415 | ! |
ui_args <- list(...) |
| 416 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 417 | ! |
ui_args$atirel, |
| 418 | ! |
ui_args$cmdecod, |
| 419 | ! |
ui_args$cmindc, |
| 420 | ! |
ui_args$cmdose, |
| 421 | ! |
ui_args$cmtrt, |
| 422 | ! |
ui_args$cmdosu, |
| 423 | ! |
ui_args$cmdosfrq, |
| 424 | ! |
ui_args$cmroute, |
| 425 | ! |
ui_args$cmstdy, |
| 426 | ! |
ui_args$cmendy |
| 427 |
) |
|
| 428 | ||
| 429 | ! |
ns <- NS(id) |
| 430 | ! |
teal.widgets::standard_layout( |
| 431 | ! |
output = tags$div( |
| 432 | ! |
htmlOutput(ns("title")),
|
| 433 | ! |
teal.widgets::get_dt_rows(ns("therapy_table"), ns("therapy_table_rows")),
|
| 434 | ! |
DT::DTOutput(outputId = ns("therapy_table")),
|
| 435 | ! |
teal.widgets::plot_with_settings_ui(id = ns("therapy_plot"))
|
| 436 |
), |
|
| 437 | ! |
encoding = tags$div( |
| 438 |
### Reporter |
|
| 439 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 440 |
### |
|
| 441 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 442 | ! |
teal.transform::datanames_input(ui_args[c( |
| 443 | ! |
"atirel", "cmdecod", "cmindc", "cmdose", "cmtrt", |
| 444 | ! |
"cmdosu", "cmroute", "cmdosfrq", "cmstdy", "cmendy" |
| 445 |
)]), |
|
| 446 | ! |
teal.widgets::optionalSelectInput( |
| 447 | ! |
ns("patient_id"),
|
| 448 | ! |
"Select Patient:", |
| 449 | ! |
multiple = FALSE, |
| 450 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 451 |
), |
|
| 452 | ! |
teal.transform::data_extract_ui( |
| 453 | ! |
id = ns("cmdecod"),
|
| 454 | ! |
label = "Select the medication decoding column:", |
| 455 | ! |
data_extract_spec = ui_args$cmdecod, |
| 456 | ! |
is_single_dataset = is_single_dataset_value |
| 457 |
), |
|
| 458 | ! |
teal.transform::data_extract_ui( |
| 459 | ! |
id = ns("atirel"),
|
| 460 | ! |
label = "Select ATIREL variable:", |
| 461 | ! |
data_extract_spec = ui_args$atirel, |
| 462 | ! |
is_single_dataset = is_single_dataset_value |
| 463 |
), |
|
| 464 | ! |
teal.transform::data_extract_ui( |
| 465 | ! |
id = ns("cmindc"),
|
| 466 | ! |
label = "Select CMINDC variable:", |
| 467 | ! |
data_extract_spec = ui_args$cmindc, |
| 468 | ! |
is_single_dataset = is_single_dataset_value |
| 469 |
), |
|
| 470 | ! |
teal.transform::data_extract_ui( |
| 471 | ! |
id = ns("cmdose"),
|
| 472 | ! |
label = "Select CMDOSE variable:", |
| 473 | ! |
data_extract_spec = ui_args$cmdose, |
| 474 | ! |
is_single_dataset = is_single_dataset_value |
| 475 |
), |
|
| 476 | ! |
teal.transform::data_extract_ui( |
| 477 | ! |
id = ns("cmtrt"),
|
| 478 | ! |
label = "Select CMTRT variable:", |
| 479 | ! |
data_extract_spec = ui_args$cmtrt, |
| 480 | ! |
is_single_dataset = is_single_dataset_value |
| 481 |
), |
|
| 482 | ! |
teal.transform::data_extract_ui( |
| 483 | ! |
id = ns("cmdosu"),
|
| 484 | ! |
label = "Select CMDOSU variable:", |
| 485 | ! |
data_extract_spec = ui_args$cmdosu, |
| 486 | ! |
is_single_dataset = is_single_dataset_value |
| 487 |
), |
|
| 488 | ! |
teal.transform::data_extract_ui( |
| 489 | ! |
id = ns("cmroute"),
|
| 490 | ! |
label = "Select CMROUTE variable:", |
| 491 | ! |
data_extract_spec = ui_args$cmroute, |
| 492 | ! |
is_single_dataset = is_single_dataset_value |
| 493 |
), |
|
| 494 | ! |
teal.transform::data_extract_ui( |
| 495 | ! |
id = ns("cmdosfrq"),
|
| 496 | ! |
label = "Select CMDOSFRQ variable:", |
| 497 | ! |
data_extract_spec = ui_args$cmdosfrq, |
| 498 | ! |
is_single_dataset = is_single_dataset_value |
| 499 |
), |
|
| 500 | ! |
teal.transform::data_extract_ui( |
| 501 | ! |
id = ns("cmstdy"),
|
| 502 | ! |
label = "Select CMSTDY variable:", |
| 503 | ! |
data_extract_spec = ui_args$cmstdy, |
| 504 | ! |
is_single_dataset = is_single_dataset_value |
| 505 |
), |
|
| 506 | ! |
teal.transform::data_extract_ui( |
| 507 | ! |
id = ns("cmendy"),
|
| 508 | ! |
label = "Select CMENDY variable:", |
| 509 | ! |
data_extract_spec = ui_args$cmendy, |
| 510 | ! |
is_single_dataset = is_single_dataset_value |
| 511 |
), |
|
| 512 | ! |
teal.widgets::panel_item( |
| 513 | ! |
title = "Plot settings", |
| 514 | ! |
collapsed = TRUE, |
| 515 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 516 | ! |
ns("font_size"),
|
| 517 | ! |
"Font Size", |
| 518 | ! |
ui_args$font_size, |
| 519 | ! |
ticks = FALSE, |
| 520 | ! |
step = 1 |
| 521 |
) |
|
| 522 |
) |
|
| 523 |
), |
|
| 524 | ! |
forms = tagList( |
| 525 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 526 |
), |
|
| 527 | ! |
pre_output = ui_args$pre_output, |
| 528 | ! |
post_output = ui_args$post_output |
| 529 |
) |
|
| 530 |
} |
|
| 531 | ||
| 532 |
#' @keywords internal |
|
| 533 |
srv_g_therapy <- function(id, |
|
| 534 |
data, |
|
| 535 |
reporter, |
|
| 536 |
filter_panel_api, |
|
| 537 |
dataname, |
|
| 538 |
parentname, |
|
| 539 |
patient_col, |
|
| 540 |
atirel, |
|
| 541 |
cmdecod, |
|
| 542 |
cmindc, |
|
| 543 |
cmdose, |
|
| 544 |
cmtrt, |
|
| 545 |
cmdosu, |
|
| 546 |
cmdosfrq, |
|
| 547 |
cmroute, |
|
| 548 |
cmstdy, |
|
| 549 |
cmendy, |
|
| 550 |
plot_height, |
|
| 551 |
plot_width, |
|
| 552 |
label, |
|
| 553 |
ggplot2_args) {
|
|
| 554 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 555 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 556 | ! |
checkmate::assert_class(data, "reactive") |
| 557 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 558 | ||
| 559 | ! |
moduleServer(id, function(input, output, session) {
|
| 560 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 561 | ! |
patient_id <- reactive(input$patient_id) |
| 562 | ||
| 563 |
# Init |
|
| 564 | ! |
patient_data_base <- reactive(unique(data()[[parentname]][[patient_col]])) |
| 565 | ! |
teal.widgets::updateOptionalSelectInput( |
| 566 | ! |
session, "patient_id", |
| 567 | ! |
choices = patient_data_base(), selected = patient_data_base()[1] |
| 568 |
) |
|
| 569 | ||
| 570 | ! |
observeEvent(patient_data_base(), |
| 571 | ! |
handlerExpr = {
|
| 572 | ! |
teal.widgets::updateOptionalSelectInput( |
| 573 | ! |
session, |
| 574 | ! |
"patient_id", |
| 575 | ! |
choices = patient_data_base(), |
| 576 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 577 | ! |
patient_data_base() |
| 578 |
} else {
|
|
| 579 | ! |
intersect(patient_id(), patient_data_base()) |
| 580 |
} |
|
| 581 |
) |
|
| 582 |
}, |
|
| 583 | ! |
ignoreInit = TRUE |
| 584 |
) |
|
| 585 | ||
| 586 |
# Therapy tab ---- |
|
| 587 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 588 | ! |
data_extract = list( |
| 589 | ! |
atirel = atirel, cmdecod = cmdecod, cmindc = cmindc, |
| 590 | ! |
cmdose = cmdose, cmtrt = cmtrt, cmdosu = cmdosu, |
| 591 | ! |
cmroute = cmroute, cmdosfrq = cmdosfrq, cmstdy = cmstdy, cmendy = cmendy |
| 592 |
), |
|
| 593 | ! |
datasets = data, |
| 594 | ! |
select_validation_rule = list( |
| 595 | ! |
atirel = shinyvalidate::sv_required("Please select ATIREL variable."),
|
| 596 | ! |
cmdecod = shinyvalidate::sv_required("Please select medication decoding variable."),
|
| 597 | ! |
cmindc = shinyvalidate::sv_required("Please select CMINDC variable."),
|
| 598 | ! |
cmdose = shinyvalidate::sv_required("Please select CMDOSE variable."),
|
| 599 | ! |
cmtrt = shinyvalidate::sv_required("Please select CMTRT variable."),
|
| 600 | ! |
cmdosu = shinyvalidate::sv_required("Please select CMDOSU variable."),
|
| 601 | ! |
cmroute = shinyvalidate::sv_required("Please select CMROUTE variable."),
|
| 602 | ! |
cmdosfrq = shinyvalidate::sv_required("Please select CMDOSFRQ variable."),
|
| 603 | ! |
cmstdy = shinyvalidate::sv_required("Please select CMSTDY variable."),
|
| 604 | ! |
cmendy = shinyvalidate::sv_required("Please select CMENDY variable.")
|
| 605 |
) |
|
| 606 |
) |
|
| 607 | ||
| 608 | ! |
iv_r <- reactive({
|
| 609 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 610 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient."))
|
| 611 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 612 |
}) |
|
| 613 | ||
| 614 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 615 | ! |
datasets = data, |
| 616 | ! |
selector_list = selector_list, |
| 617 | ! |
merge_function = "dplyr::left_join" |
| 618 |
) |
|
| 619 | ||
| 620 | ! |
anl_q <- reactive({
|
| 621 | ! |
data() %>% |
| 622 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 623 |
}) |
|
| 624 | ||
| 625 | ! |
merged <- list(anl_input_r = anl_inputs, anl_q = anl_q) |
| 626 | ||
| 627 | ! |
all_q <- reactive({
|
| 628 | ! |
teal::validate_has_data(merged$anl_q()[["ANL"]], 1) |
| 629 | ||
| 630 | ! |
teal::validate_inputs(iv_r()) |
| 631 | ||
| 632 | ! |
validate( |
| 633 | ! |
need( |
| 634 | ! |
nrow(merged$anl_q()[["ANL"]][input$patient_id == merged$anl_q()[["ANL"]][, patient_col], ]) > 0, |
| 635 | ! |
"Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." |
| 636 |
) |
|
| 637 |
) |
|
| 638 | ||
| 639 | ! |
my_calls <- template_therapy( |
| 640 | ! |
dataname = "ANL", |
| 641 | ! |
atirel = input[[extract_input("atirel", dataname)]],
|
| 642 | ! |
cmdecod = input[[extract_input("cmdecod", dataname)]],
|
| 643 | ! |
cmtrt = input[[extract_input("cmtrt", dataname)]],
|
| 644 | ! |
cmdosu = input[[extract_input("cmdosu", dataname)]],
|
| 645 | ! |
cmroute = input[[extract_input("cmroute", dataname)]],
|
| 646 | ! |
cmdosfrq = input[[extract_input("cmdosfrq", dataname)]],
|
| 647 | ! |
cmstdy = input[[extract_input("cmstdy", dataname)]],
|
| 648 | ! |
cmendy = input[[extract_input("cmendy", dataname)]],
|
| 649 | ! |
cmindc = input[[extract_input("cmindc", dataname)]],
|
| 650 | ! |
cmdose = input[[extract_input("cmdose", dataname)]],
|
| 651 | ! |
patient_id = patient_id(), |
| 652 | ! |
font_size = input[["font_size"]], |
| 653 | ! |
ggplot2_args = ggplot2_args |
| 654 |
) |
|
| 655 | ||
| 656 | ! |
teal.code::eval_code( |
| 657 | ! |
merged$anl_q(), |
| 658 | ! |
substitute( |
| 659 | ! |
expr = {
|
| 660 | ! |
pt_id <- patient_id |
| 661 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 662 | ! |
}, env = list( |
| 663 | ! |
patient_col = patient_col, |
| 664 | ! |
patient_id = patient_id() |
| 665 |
) |
|
| 666 |
) |
|
| 667 |
) %>% |
|
| 668 | ! |
teal.code::eval_code(as.expression(my_calls)) |
| 669 |
}) |
|
| 670 | ||
| 671 | ! |
output$title <- renderText({
|
| 672 | ! |
paste("<h5><b>Patient ID:", all_q()[["pt_id"]], "</b></h5>")
|
| 673 |
}) |
|
| 674 | ||
| 675 | ! |
output$therapy_table <- DT::renderDataTable( |
| 676 | ! |
expr = {
|
| 677 | ! |
teal.code::dev_suppress(all_q()[["therapy_table"]]) |
| 678 |
}, |
|
| 679 | ! |
options = list(pageLength = input$therapy_table_rows) |
| 680 |
) |
|
| 681 | ||
| 682 | ! |
plot_r <- reactive({
|
| 683 | ! |
req(iv_r()$is_valid()) |
| 684 | ! |
all_q()[["therapy_plot"]] |
| 685 |
}) |
|
| 686 | ||
| 687 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 688 | ! |
id = "therapy_plot", |
| 689 | ! |
plot_r = plot_r, |
| 690 | ! |
height = plot_height, |
| 691 | ! |
width = plot_width |
| 692 |
) |
|
| 693 | ||
| 694 | ! |
teal.widgets::verbatim_popup_srv( |
| 695 | ! |
id = "rcode", |
| 696 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 697 | ! |
title = label |
| 698 |
) |
|
| 699 | ||
| 700 |
### REPORTER |
|
| 701 | ! |
if (with_reporter) {
|
| 702 | ! |
card_fun <- function(comment, label) {
|
| 703 | ! |
card <- teal::report_card_template( |
| 704 | ! |
title = "Patient Profile Therapy", |
| 705 | ! |
label = label, |
| 706 | ! |
with_filter = with_filter, |
| 707 | ! |
filter_panel_api = filter_panel_api |
| 708 |
) |
|
| 709 | ! |
card$append_text("Table", "header3")
|
| 710 | ! |
card$append_table(teal.code::dev_suppress(all_q()[["therapy_table"]])) |
| 711 | ! |
card$append_text("Plot", "header3")
|
| 712 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 713 | ! |
if (!comment == "") {
|
| 714 | ! |
card$append_text("Comment", "header3")
|
| 715 | ! |
card$append_text(comment) |
| 716 |
} |
|
| 717 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 718 | ! |
card |
| 719 |
} |
|
| 720 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 721 |
} |
|
| 722 |
### |
|
| 723 |
}) |
|
| 724 |
} |
| 1 |
#' teal Module: Simple Bar Chart and Table of Counts per Category |
|
| 2 |
#' |
|
| 3 |
#' This module produces a [ggplot2::ggplot()] type bar chart and summary table of counts per category. |
|
| 4 |
#' |
|
| 5 |
#' Categories can be defined up to four levels deep and are defined through the `x`, `fill`, |
|
| 6 |
#' `x_facet`, and `y_facet` parameters. Any parameters set to `NULL` (default) are ignored. |
|
| 7 |
#' |
|
| 8 |
#' @inheritParams module_arguments |
|
| 9 |
#' @inheritParams template_arguments |
|
| 10 |
#' @param x (`data_extract_spec`)\cr variable on the x-axis. |
|
| 11 |
#' @param fill (`data_extract_spec`)\cr grouping variable to determine bar colors. |
|
| 12 |
#' @param x_facet (`data_extract_spec`)\cr row-wise faceting groups. |
|
| 13 |
#' @param y_facet (`data_extract_spec`)\cr column-wise faceting groups. |
|
| 14 |
#' @param plot_options (`list`)\cr list of plot options. |
|
| 15 |
#' |
|
| 16 |
#' @inherit module_arguments return seealso |
|
| 17 |
#' |
|
| 18 |
#' @examples |
|
| 19 |
#' library(nestcolor) |
|
| 20 |
#' library(dplyr) |
|
| 21 |
#' |
|
| 22 |
#' ADSL <- tmc_ex_adsl %>% |
|
| 23 |
#' mutate(ITTFL = factor("Y") %>%
|
|
| 24 |
#' with_label("Intent-To-Treat Population Flag"))
|
|
| 25 |
#' ADAE <- tmc_ex_adae %>% |
|
| 26 |
#' filter(!((AETOXGR == 1) & (AESEV == "MILD") & (ARM == "A: Drug X"))) |
|
| 27 |
#' |
|
| 28 |
#' app <- init( |
|
| 29 |
#' data = cdisc_data( |
|
| 30 |
#' ADSL = ADSL, |
|
| 31 |
#' ADAE = ADAE, |
|
| 32 |
#' code = "ADSL <- tmc_ex_adsl %>% |
|
| 33 |
#' mutate(ITTFL = factor(\"Y\") %>% |
|
| 34 |
#' with_label(\"Intent-To-Treat Population Flag\")) |
|
| 35 |
#' ADAE <- tmc_ex_adae %>% |
|
| 36 |
#' filter(!((AETOXGR == 1) & (AESEV == \"MILD\") & (ARM == \"A: Drug X\")))" |
|
| 37 |
#' ), |
|
| 38 |
#' modules = modules( |
|
| 39 |
#' tm_g_barchart_simple( |
|
| 40 |
#' label = "ADAE Analysis", |
|
| 41 |
#' x = data_extract_spec( |
|
| 42 |
#' dataname = "ADSL", |
|
| 43 |
#' select = select_spec( |
|
| 44 |
#' choices = variable_choices( |
|
| 45 |
#' ADSL, |
|
| 46 |
#' c( |
|
| 47 |
#' "ARM", "ACTARM", "SEX", |
|
| 48 |
#' "RACE", "ITTFL", "SAFFL", "STRATA2" |
|
| 49 |
#' ) |
|
| 50 |
#' ), |
|
| 51 |
#' selected = "ACTARM", |
|
| 52 |
#' multiple = FALSE |
|
| 53 |
#' ) |
|
| 54 |
#' ), |
|
| 55 |
#' fill = list( |
|
| 56 |
#' data_extract_spec( |
|
| 57 |
#' dataname = "ADSL", |
|
| 58 |
#' select = select_spec( |
|
| 59 |
#' choices = variable_choices( |
|
| 60 |
#' ADSL, |
|
| 61 |
#' c( |
|
| 62 |
#' "ARM", "ACTARM", "SEX", |
|
| 63 |
#' "RACE", "ITTFL", "SAFFL", "STRATA2" |
|
| 64 |
#' ) |
|
| 65 |
#' ), |
|
| 66 |
#' selected = "SEX", |
|
| 67 |
#' multiple = FALSE |
|
| 68 |
#' ) |
|
| 69 |
#' ), |
|
| 70 |
#' data_extract_spec( |
|
| 71 |
#' dataname = "ADAE", |
|
| 72 |
#' select = select_spec( |
|
| 73 |
#' choices = variable_choices(ADAE, c("AETOXGR", "AESEV", "AESER")),
|
|
| 74 |
#' selected = NULL, |
|
| 75 |
#' multiple = FALSE |
|
| 76 |
#' ) |
|
| 77 |
#' ) |
|
| 78 |
#' ), |
|
| 79 |
#' x_facet = list( |
|
| 80 |
#' data_extract_spec( |
|
| 81 |
#' dataname = "ADAE", |
|
| 82 |
#' select = select_spec( |
|
| 83 |
#' choices = variable_choices(ADAE, c("AETOXGR", "AESEV", "AESER")),
|
|
| 84 |
#' selected = "AETOXGR", |
|
| 85 |
#' multiple = FALSE |
|
| 86 |
#' ) |
|
| 87 |
#' ), |
|
| 88 |
#' data_extract_spec( |
|
| 89 |
#' dataname = "ADSL", |
|
| 90 |
#' select = select_spec( |
|
| 91 |
#' choices = variable_choices( |
|
| 92 |
#' ADSL, |
|
| 93 |
#' c( |
|
| 94 |
#' "ARM", "ACTARM", "SEX", |
|
| 95 |
#' "RACE", "ITTFL", "SAFFL", "STRATA2" |
|
| 96 |
#' ) |
|
| 97 |
#' ), |
|
| 98 |
#' selected = NULL, |
|
| 99 |
#' multiple = FALSE |
|
| 100 |
#' ) |
|
| 101 |
#' ) |
|
| 102 |
#' ), |
|
| 103 |
#' y_facet = list( |
|
| 104 |
#' data_extract_spec( |
|
| 105 |
#' dataname = "ADAE", |
|
| 106 |
#' select = select_spec( |
|
| 107 |
#' choices = variable_choices(ADAE, c("AETOXGR", "AESEV", "AESER")),
|
|
| 108 |
#' selected = "AESEV", |
|
| 109 |
#' multiple = FALSE |
|
| 110 |
#' ) |
|
| 111 |
#' ), |
|
| 112 |
#' data_extract_spec( |
|
| 113 |
#' dataname = "ADSL", |
|
| 114 |
#' select = select_spec( |
|
| 115 |
#' choices = variable_choices( |
|
| 116 |
#' ADSL, |
|
| 117 |
#' c( |
|
| 118 |
#' "ARM", "ACTARM", "SEX", |
|
| 119 |
#' "RACE", "ITTFL", "SAFFL", "STRATA2" |
|
| 120 |
#' ) |
|
| 121 |
#' ), |
|
| 122 |
#' selected = NULL, |
|
| 123 |
#' multiple = FALSE |
|
| 124 |
#' ) |
|
| 125 |
#' ) |
|
| 126 |
#' ) |
|
| 127 |
#' ) |
|
| 128 |
#' ) |
|
| 129 |
#' ) |
|
| 130 |
#' if (interactive()) {
|
|
| 131 |
#' shinyApp(app$ui, app$server) |
|
| 132 |
#' } |
|
| 133 |
#' |
|
| 134 |
#' @export |
|
| 135 |
tm_g_barchart_simple <- function(x = NULL, |
|
| 136 |
fill = NULL, |
|
| 137 |
x_facet = NULL, |
|
| 138 |
y_facet = NULL, |
|
| 139 |
label = "Count Barchart", |
|
| 140 |
plot_options = NULL, |
|
| 141 |
plot_height = c(600L, 200L, 2000L), |
|
| 142 |
plot_width = NULL, |
|
| 143 |
pre_output = NULL, |
|
| 144 |
post_output = NULL, |
|
| 145 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 146 | ! |
message("Initializing tm_g_barchart_simple")
|
| 147 | ! |
checkmate::assert_string(label) |
| 148 | ! |
checkmate::assert_list(plot_options, null.ok = TRUE) |
| 149 | ! |
if (length(c(x, fill, x_facet, y_facet)) == 0) {
|
| 150 | ! |
stop("at least one must be specified. 'x', 'fill', 'x_facet', 'y_facet' is NULL")
|
| 151 |
} |
|
| 152 | ! |
x <- teal.transform::list_extract_spec(x, allow_null = TRUE) |
| 153 | ! |
fill <- teal.transform::list_extract_spec(fill, allow_null = TRUE) |
| 154 | ! |
x_facet <- teal.transform::list_extract_spec(x_facet, allow_null = TRUE) |
| 155 | ! |
y_facet <- teal.transform::list_extract_spec(y_facet, allow_null = TRUE) |
| 156 | ! |
teal.transform::check_no_multiple_selection(x) |
| 157 | ! |
teal.transform::check_no_multiple_selection(fill) |
| 158 | ! |
teal.transform::check_no_multiple_selection(x_facet) |
| 159 | ! |
teal.transform::check_no_multiple_selection(y_facet) |
| 160 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 161 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 162 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 163 | ! |
checkmate::assert_numeric( |
| 164 | ! |
plot_width[1], |
| 165 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 166 |
) |
|
| 167 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 168 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 169 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 170 | ||
| 171 | ! |
plot_options <- utils::modifyList( |
| 172 | ! |
list(stacked = FALSE), # default |
| 173 | ! |
`if`(is.null(plot_options), list(), plot_options) |
| 174 |
) |
|
| 175 | ||
| 176 | ! |
ui_args <- as.list(environment()) |
| 177 | ! |
module( |
| 178 | ! |
label = label, |
| 179 | ! |
server = srv_g_barchart_simple, |
| 180 | ! |
ui = ui_g_barchart_simple, |
| 181 | ! |
ui_args = ui_args, |
| 182 | ! |
server_args = list( |
| 183 | ! |
x = x, |
| 184 | ! |
fill = fill, |
| 185 | ! |
x_facet = x_facet, |
| 186 | ! |
y_facet = y_facet, |
| 187 | ! |
plot_height = plot_height, |
| 188 | ! |
plot_width = plot_width, |
| 189 | ! |
ggplot2_args = ggplot2_args |
| 190 |
), |
|
| 191 | ! |
datanames = "all" |
| 192 |
) |
|
| 193 |
} |
|
| 194 | ||
| 195 |
#' @keywords internal |
|
| 196 |
ui_g_barchart_simple <- function(id, ...) {
|
|
| 197 | ! |
ns <- NS(id) |
| 198 | ! |
args <- list(...) |
| 199 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset(args$x, args$fill, args$x_facet, args$y_facet) |
| 200 | ||
| 201 | ! |
tagList( |
| 202 | ! |
singleton( |
| 203 | ! |
tags$head(includeCSS(system.file("css/custom.css", package = "teal.modules.clinical")))
|
| 204 |
), |
|
| 205 | ! |
teal.widgets::standard_layout( |
| 206 | ! |
output = teal.widgets::white_small_well( |
| 207 | ! |
teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 208 | ! |
uiOutput(ns("table"), class = "overflow-y-scroll max-h-250")
|
| 209 |
), |
|
| 210 | ! |
encoding = tags$div( |
| 211 |
### Reporter |
|
| 212 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 213 |
### |
|
| 214 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 215 | ! |
teal.transform::datanames_input(args[c("x", "fill", "x_facet", "y_facet")]),
|
| 216 | ! |
if (!is.null(args$x)) {
|
| 217 | ! |
teal.transform::data_extract_ui( |
| 218 | ! |
id = ns("x"),
|
| 219 | ! |
label = "X variable", |
| 220 | ! |
data_extract_spec = args$x, |
| 221 | ! |
is_single_dataset = is_single_dataset_value |
| 222 |
) |
|
| 223 |
}, |
|
| 224 | ! |
if (!is.null(args$fill)) {
|
| 225 | ! |
teal.transform::data_extract_ui( |
| 226 | ! |
id = ns("fill"),
|
| 227 | ! |
label = "Fill", |
| 228 | ! |
data_extract_spec = args$fill, |
| 229 | ! |
is_single_dataset = is_single_dataset_value |
| 230 |
) |
|
| 231 |
}, |
|
| 232 | ! |
if (!is.null(args$x_facet)) {
|
| 233 | ! |
teal.transform::data_extract_ui( |
| 234 | ! |
id = ns("x_facet"),
|
| 235 | ! |
label = "Column facetting variable", |
| 236 | ! |
data_extract_spec = args$x_facet, |
| 237 | ! |
is_single_dataset = is_single_dataset_value |
| 238 |
) |
|
| 239 |
}, |
|
| 240 | ! |
if (!is.null(args$y_facet)) {
|
| 241 | ! |
teal.transform::data_extract_ui( |
| 242 | ! |
id = ns("y_facet"),
|
| 243 | ! |
label = "Row facetting variable", |
| 244 | ! |
data_extract_spec = args$y_facet, |
| 245 | ! |
is_single_dataset = is_single_dataset_value |
| 246 |
) |
|
| 247 |
}, |
|
| 248 | ! |
teal.widgets::panel_group( |
| 249 | ! |
teal.widgets::panel_item( |
| 250 | ! |
"Additional plot settings", |
| 251 | ! |
if (!is.null(args$fill)) {
|
| 252 | ! |
radioButtons( |
| 253 | ! |
inputId = ns("barlayout"),
|
| 254 | ! |
label = "Covariate Bar Layout", |
| 255 | ! |
choices = c("Side by side" = "side_by_side", "Stacked" = "stacked"),
|
| 256 | ! |
selected = if (args$plot_options$stacked) "stacked" else "side_by_side", |
| 257 | ! |
inline = TRUE |
| 258 |
) |
|
| 259 |
}, |
|
| 260 | ! |
if (!(is.null(args$x_facet))) {
|
| 261 | ! |
checkboxInput( |
| 262 | ! |
ns("facet_scale_x"),
|
| 263 | ! |
"Fixed scales for column facets", |
| 264 | ! |
value = TRUE |
| 265 |
) |
|
| 266 |
}, |
|
| 267 | ! |
if (!(is.null(args$y_facet))) {
|
| 268 | ! |
checkboxInput( |
| 269 | ! |
ns("facet_scale_y"),
|
| 270 | ! |
"Fixed scales for row facets", |
| 271 | ! |
value = TRUE |
| 272 |
) |
|
| 273 |
}, |
|
| 274 | ! |
checkboxInput( |
| 275 | ! |
ns("label_bars"),
|
| 276 | ! |
"Label bars", |
| 277 | ! |
value = `if`(is.null(args$plot_options$label_bars), TRUE, args$plot_options$label_bars) |
| 278 |
), |
|
| 279 | ! |
checkboxInput( |
| 280 | ! |
ns("rotate_bar_labels"),
|
| 281 | ! |
"Rotate bar labels", |
| 282 | ! |
value = `if`(is.null(args$plot_options$rotate_bar_labels), FALSE, args$plot_options$rotate_bar_labels) |
| 283 |
), |
|
| 284 | ! |
checkboxInput( |
| 285 | ! |
ns("rotate_x_label"),
|
| 286 | ! |
"Rotate x label", |
| 287 | ! |
value = `if`(is.null(args$plot_options$rotate_x_label), FALSE, args$plot_options$rotate_x_label) |
| 288 |
), |
|
| 289 | ! |
checkboxInput( |
| 290 | ! |
ns("rotate_y_label"),
|
| 291 | ! |
"Rotate y label", |
| 292 | ! |
value = `if`(is.null(args$plot_options$rotate_y_label), FALSE, args$plot_options$rotate_y_label) |
| 293 |
), |
|
| 294 | ! |
checkboxInput( |
| 295 | ! |
ns("flip_axis"),
|
| 296 | ! |
"Flip axes", |
| 297 | ! |
value = `if`(is.null(args$plot_options$flip_axis), FALSE, args$plot_options$flip_axis) |
| 298 |
), |
|
| 299 | ! |
checkboxInput( |
| 300 | ! |
ns("show_n"),
|
| 301 | ! |
"Show n", |
| 302 | ! |
value = `if`(is.null(args$plot_options$show_n), TRUE, args$plot_options$show_n) |
| 303 |
), |
|
| 304 | ! |
sliderInput( |
| 305 | ! |
inputId = ns("expand_y_range"),
|
| 306 | ! |
label = "Y-axis range expansion (fraction on top)", |
| 307 | ! |
min = 0, |
| 308 | ! |
max = 1, |
| 309 | ! |
value = 0.5, |
| 310 | ! |
step = 0.1 |
| 311 |
) |
|
| 312 |
) |
|
| 313 |
) |
|
| 314 |
) |
|
| 315 |
), |
|
| 316 | ! |
forms = tagList( |
| 317 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 318 |
), |
|
| 319 | ! |
pre_output = args$pre_output, |
| 320 | ! |
post_output = args$post_output |
| 321 |
) |
|
| 322 |
} |
|
| 323 | ||
| 324 |
#' @keywords internal |
|
| 325 |
srv_g_barchart_simple <- function(id, |
|
| 326 |
data, |
|
| 327 |
reporter, |
|
| 328 |
filter_panel_api, |
|
| 329 |
x, |
|
| 330 |
fill, |
|
| 331 |
x_facet, |
|
| 332 |
y_facet, |
|
| 333 |
plot_height, |
|
| 334 |
plot_width, |
|
| 335 |
ggplot2_args) {
|
|
| 336 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 337 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 338 | ! |
checkmate::assert_class(data, "reactive") |
| 339 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 340 | ||
| 341 | ! |
moduleServer(id, function(input, output, session) {
|
| 342 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 343 | ! |
rule_dupl <- function(others) {
|
| 344 | ! |
function(value) {
|
| 345 | ! |
othervals <- lapply( |
| 346 | ! |
Filter(Negate(is.null), selector_list()[others]), # some selectors could be ommited in tm_g_barchart_simple |
| 347 | ! |
function(x) x()$select |
| 348 |
) |
|
| 349 | ! |
vars <- c(value, unlist(othervals)) |
| 350 | ! |
dups <- unique(vars[duplicated(vars)]) |
| 351 | ! |
if (value %in% dups) {
|
| 352 | ! |
paste("Duplicated value:", value, collapse = ", ")
|
| 353 |
} |
|
| 354 |
} |
|
| 355 |
} |
|
| 356 | ||
| 357 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 358 | ! |
data_extract = list(x = x, fill = fill, x_facet = x_facet, y_facet = y_facet), |
| 359 | ! |
datasets = data, |
| 360 | ! |
select_validation_rule = list( |
| 361 | ! |
x = shinyvalidate::compose_rules( |
| 362 | ! |
shinyvalidate::sv_required("Please select an x-variable"),
|
| 363 | ! |
rule_dupl(others = c("fill", "x_facet", "y_facet"))
|
| 364 |
), |
|
| 365 | ! |
fill = shinyvalidate::compose_rules( |
| 366 | ! |
shinyvalidate::sv_optional(), |
| 367 | ! |
rule_dupl(others = c("x", "x_facet", "y_facet"))
|
| 368 |
), |
|
| 369 | ! |
x_facet = shinyvalidate::compose_rules( |
| 370 | ! |
shinyvalidate::sv_optional(), |
| 371 | ! |
rule_dupl(others = c("fill", "x", "y_facet"))
|
| 372 |
), |
|
| 373 | ! |
y_facet = shinyvalidate::compose_rules( |
| 374 | ! |
shinyvalidate::sv_optional(), |
| 375 | ! |
rule_dupl(others = c("fill", "x_facet", "x"))
|
| 376 |
) |
|
| 377 |
), |
|
| 378 | ! |
dataset_validation_rule = list( |
| 379 | ! |
fill = NULL, |
| 380 | ! |
x_facet = NULL, |
| 381 | ! |
y_facet = NULL |
| 382 |
) |
|
| 383 |
) |
|
| 384 | ||
| 385 | ! |
iv_r <- reactive({
|
| 386 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 387 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 388 |
}) |
|
| 389 | ||
| 390 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 391 | ! |
datasets = data, |
| 392 | ! |
selector_list = selector_list |
| 393 |
) |
|
| 394 | ||
| 395 | ! |
anl_q <- reactive({
|
| 396 | ! |
data() %>% |
| 397 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 398 |
}) |
|
| 399 | ||
| 400 | ! |
count_q <- reactive({
|
| 401 | ! |
anl_q <- anl_q() |
| 402 | ! |
teal::validate_has_data(anl_q[["ANL"]], 2) |
| 403 | ! |
groupby_vars <- r_groupby_vars() |
| 404 | ||
| 405 |
# count |
|
| 406 | ! |
count_by_group <- function(groupby_vars, data_name) {
|
| 407 | ! |
n_name <- get_n_name(groupby_vars) |
| 408 | ! |
count_by_group_expr(groupby_vars = groupby_vars, data_name = data_name) |
| 409 |
} |
|
| 410 | ||
| 411 | ! |
count_exprs <- count_by_group(groupby_vars, data_name = "ANL") |
| 412 | ||
| 413 | ! |
if (input$show_n) {
|
| 414 | ! |
count_exprs2 <- sapply(groupby_vars[-1], count_by_group, data_name = "counts") |
| 415 | ! |
count_str_to_col_exprs <- sapply(groupby_vars[-1], count_str_to_column_expr) |
| 416 | ! |
count_exprs <- c(count_exprs, count_exprs2, count_str_to_col_exprs) |
| 417 |
} |
|
| 418 | ||
| 419 | ! |
data_list <- sapply(teal.data::datanames(data()), function(x) reactive(data()[[x]]), |
| 420 | ! |
simplify = FALSE |
| 421 |
) |
|
| 422 | ||
| 423 | ! |
anl_q <- anl_q %>% |
| 424 | ! |
teal.code::eval_code(code = count_exprs) |
| 425 | ||
| 426 |
# add label and slice(1) as all patients in the same subgroup have same n_'s |
|
| 427 | ! |
anl_q <- anl_q %>% |
| 428 | ! |
teal.code::eval_code( |
| 429 | ! |
as.expression( |
| 430 | ! |
c( |
| 431 | ! |
bquote(attr(counts[[.(get_n_name(groupby_vars))]], "label") <- "Count"), |
| 432 | ! |
bquote( |
| 433 | ! |
counts <- counts %>% |
| 434 | ! |
dplyr::group_by_at(.(as.vector(groupby_vars))) %>% |
| 435 | ! |
dplyr::slice(1) %>% |
| 436 | ! |
dplyr::ungroup() %>% |
| 437 | ! |
dplyr::select(.(as.vector(groupby_vars)), dplyr::starts_with("n_"))
|
| 438 |
) |
|
| 439 |
) |
|
| 440 |
) |
|
| 441 |
) |
|
| 442 | ||
| 443 |
# dplyr::select loses labels |
|
| 444 | ! |
anl_q %>% |
| 445 | ! |
teal.code::eval_code( |
| 446 | ! |
teal.transform::get_anl_relabel_call( |
| 447 | ! |
columns_source = anl_inputs()$columns_source, |
| 448 | ! |
datasets = data_list, |
| 449 | ! |
anl_name = "counts" |
| 450 |
) |
|
| 451 |
) |
|
| 452 |
}) |
|
| 453 | ||
| 454 | ! |
all_q <- reactive({
|
| 455 | ! |
teal::validate_inputs(iv_r()) |
| 456 | ! |
groupby_vars <- as.list(r_groupby_vars()) # so $ access works below |
| 457 | ||
| 458 | ! |
y_lab <- substitute( |
| 459 | ! |
column_annotation_label(counts, y_name), |
| 460 | ! |
list(y_name = get_n_name(groupby_vars)) |
| 461 |
) |
|
| 462 | ||
| 463 | ! |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 464 | ! |
user_plot = ggplot2_args, |
| 465 | ! |
module_plot = teal.widgets::ggplot2_args( |
| 466 | ! |
labs = list( |
| 467 | ! |
title = quote(plot_title), |
| 468 | ! |
y = y_lab |
| 469 |
), |
|
| 470 | ! |
theme = list(plot.title = quote(ggplot2::element_text(hjust = 0.5))) |
| 471 |
) |
|
| 472 |
) |
|
| 473 | ||
| 474 | ! |
plot_call <- make_barchart_simple_call( |
| 475 | ! |
y_name = get_n_name(groupby_vars), |
| 476 | ! |
x_name = groupby_vars$x_name, |
| 477 | ! |
fill_name = groupby_vars$fill_name, |
| 478 | ! |
x_facet_name = groupby_vars$x_facet_name, |
| 479 | ! |
y_facet_name = groupby_vars$y_facet_name, |
| 480 | ! |
label_bars = input$label_bars, |
| 481 | ! |
barlayout = input$barlayout, |
| 482 | ! |
flip_axis = input$flip_axis, |
| 483 | ! |
rotate_bar_labels = input$rotate_bar_labels, |
| 484 | ! |
rotate_x_label = input$rotate_x_label, |
| 485 | ! |
rotate_y_label = input$rotate_y_label, |
| 486 | ! |
expand_y_range = input$expand_y_range, |
| 487 | ! |
facet_scales = get_facet_scale(input$facet_scale_x, input$facet_scale_y), |
| 488 | ! |
ggplot2_args = all_ggplot2_args |
| 489 |
) |
|
| 490 | ||
| 491 | ! |
ANL <- count_q()[["ANL"]] |
| 492 | ||
| 493 | ! |
all_q <- count_q() %>% |
| 494 | ! |
teal.code::eval_code(substitute( |
| 495 | ! |
env = list(groupby_vars = paste(groupby_vars, collapse = ", ")), |
| 496 | ! |
plot_title <- sprintf( |
| 497 | ! |
"Number of patients (total N = %s) for each combination of (%s)", |
| 498 | ! |
nrow(ANL), |
| 499 | ! |
groupby_vars |
| 500 |
) |
|
| 501 |
)) %>% |
|
| 502 | ! |
teal.code::eval_code(code = plot_call) |
| 503 | ||
| 504 |
# explicitly calling print on the plot inside the qenv evaluates |
|
| 505 |
# the ggplot call and therefore catches errors |
|
| 506 | ! |
teal.code::eval_code(all_q, code = quote(print(plot))) |
| 507 |
}) |
|
| 508 | ||
| 509 | ! |
plot_r <- reactive(all_q()[["plot"]]) |
| 510 | ||
| 511 | ! |
output$table <- renderTable({
|
| 512 | ! |
req(iv_r()$is_valid()) |
| 513 | ! |
teal.code::dev_suppress(all_q()[["counts"]]) |
| 514 |
}) |
|
| 515 | ||
| 516 |
# get grouping variables |
|
| 517 |
# NULL: not present in UI, vs character(0): no selection |
|
| 518 |
## returns named vector of non-NULL variables to group by |
|
| 519 | ! |
r_groupby_vars <- function() {
|
| 520 | ! |
x_name <- if (is.null(x)) NULL else as.vector(anl_inputs()$columns_source$x) |
| 521 | ! |
fill_name <- if (is.null(fill)) NULL else as.vector(anl_inputs()$columns_source$fill) |
| 522 | ! |
x_facet_name <- if (is.null(x_facet)) NULL else as.vector(anl_inputs()$columns_source$x_facet) |
| 523 | ! |
y_facet_name <- if (is.null(y_facet)) NULL else as.vector(anl_inputs()$columns_source$y_facet) |
| 524 | ||
| 525 |
# set to NULL when empty character |
|
| 526 | ! |
if (identical(x_name, character(0))) x_name <- NULL |
| 527 | ! |
if (identical(fill_name, character(0))) fill_name <- NULL |
| 528 | ! |
if (identical(x_facet_name, character(0))) x_facet_name <- NULL |
| 529 | ! |
if (identical(y_facet_name, character(0))) y_facet_name <- NULL |
| 530 | ||
| 531 | ! |
c( |
| 532 | ! |
x_name = x_name, fill_name = fill_name, |
| 533 | ! |
x_facet_name = x_facet_name, y_facet_name = y_facet_name |
| 534 | ! |
) # c() -> NULL entries are omitted |
| 535 |
} |
|
| 536 | ||
| 537 |
# Insert the plot into a plot with settings module from teal.widgets |
|
| 538 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 539 | ! |
id = "myplot", |
| 540 | ! |
plot_r = plot_r, |
| 541 | ! |
height = plot_height, |
| 542 | ! |
width = plot_width |
| 543 |
) |
|
| 544 | ||
| 545 | ! |
teal.widgets::verbatim_popup_srv( |
| 546 | ! |
id = "rcode", |
| 547 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 548 | ! |
title = "Bar Chart" |
| 549 |
) |
|
| 550 | ||
| 551 |
### REPORTER |
|
| 552 | ! |
if (with_reporter) {
|
| 553 | ! |
card_fun <- function(comment, label) {
|
| 554 | ! |
card <- teal::report_card_template( |
| 555 | ! |
title = "Barchart Plot", |
| 556 | ! |
label = label, |
| 557 | ! |
with_filter = with_filter, |
| 558 | ! |
filter_panel_api = filter_panel_api |
| 559 |
) |
|
| 560 | ! |
card$append_text("Plot", "header3")
|
| 561 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 562 | ! |
if (!comment == "") {
|
| 563 | ! |
card$append_text("Comment", "header3")
|
| 564 | ! |
card$append_text(comment) |
| 565 |
} |
|
| 566 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 567 | ! |
card |
| 568 |
} |
|
| 569 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 570 |
} |
|
| 571 |
### |
|
| 572 |
}) |
|
| 573 |
} |
|
| 574 | ||
| 575 |
# Helper functions for qenv ---- |
|
| 576 | ||
| 577 |
#' `ggplot2` call to generate simple bar chart |
|
| 578 |
#' |
|
| 579 |
#' @inheritParams tm_g_barchart_simple |
|
| 580 |
#' @param y_name (`character` or `NULL`)\cr name of the y-axis variable. |
|
| 581 |
#' @param x_name (`character` or `NULL`)\cr name of the x-axis variable. Defaults to `NULL` because it is dependent |
|
| 582 |
#' on extract input which can be empty. |
|
| 583 |
#' @param fill_name (`character` or `NULL`)\cr name of the variable to determine the bar fill color. |
|
| 584 |
#' @param x_facet_name (`character` or `NULL`)\cr name of the variable to use for horizontal plot faceting. |
|
| 585 |
#' @param y_facet_name (`character` or `NULL`)\cr name of the variable to use for vertical plot faceting. |
|
| 586 |
#' @param label_bars (`logical` or `NULL`)\cr whether bars should be labeled. If `TRUE`, label bar numbers would |
|
| 587 |
#' also be drawn as text. |
|
| 588 |
#' @param barlayout (`character` or `NULL`)\cr type of the bar layout. Options are `"stacked"` (default) or |
|
| 589 |
#' `"side_by_side"`. |
|
| 590 |
#' @param flip_axis (`character` or `NULL`)\cr whether to flip the plot axis. |
|
| 591 |
#' @param rotate_bar_labels (`logical` or `NULL`)\cr whether bar labels should be rotated by 45 degrees. |
|
| 592 |
#' @param rotate_x_label (`logical` or `NULL`)\cr whether x-axis labels should be rotated by 45 degrees. |
|
| 593 |
#' @param rotate_y_label (`logical` or `NULL`)\cr whether y-axis labels should be rotated by 45 degrees. |
|
| 594 |
#' @param expand_y_range (`numeric` or `NULL`)\cr fraction of y-axis range to further expand by. |
|
| 595 |
#' @param facet_scales (`character`)\cr value passed to `scales` argument of [ggplot2::facet_grid()]. Options are |
|
| 596 |
#' `fixed`, `free_x`, `free_y`, and `free`. |
|
| 597 |
#' |
|
| 598 |
#' @return `call` to produce a `ggplot` object. |
|
| 599 |
#' |
|
| 600 |
#' @keywords internal |
|
| 601 |
make_barchart_simple_call <- function(y_name, |
|
| 602 |
x_name = NULL, |
|
| 603 |
fill_name = NULL, |
|
| 604 |
x_facet_name = NULL, |
|
| 605 |
y_facet_name = NULL, |
|
| 606 |
label_bars = TRUE, |
|
| 607 |
barlayout = c("side_by_side", "stacked"),
|
|
| 608 |
flip_axis = FALSE, |
|
| 609 |
rotate_bar_labels = FALSE, |
|
| 610 |
rotate_x_label = FALSE, |
|
| 611 |
rotate_y_label = FALSE, |
|
| 612 |
expand_y_range = 0, |
|
| 613 |
facet_scales = "free_x", |
|
| 614 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 615 | ! |
checkmate::assert_string(y_name) |
| 616 | ! |
checkmate::assert_string(x_name, null.ok = TRUE) |
| 617 | ! |
checkmate::assert_string(fill_name, null.ok = TRUE) |
| 618 | ! |
checkmate::assert_string(x_facet_name, null.ok = TRUE) |
| 619 | ! |
checkmate::assert_string(y_facet_name, null.ok = TRUE) |
| 620 | ! |
checkmate::assert_character(c(x_name, fill_name, x_facet_name, y_facet_name)) |
| 621 | ! |
checkmate::assert_flag(label_bars) |
| 622 | ! |
checkmate::assert_scalar(expand_y_range) |
| 623 | ! |
barlayout <- match.arg(barlayout) |
| 624 | ! |
checkmate::assert_flag(flip_axis, null.ok = TRUE) |
| 625 | ! |
checkmate::assert_flag(rotate_x_label, null.ok = TRUE) |
| 626 | ! |
checkmate::assert_flag(rotate_y_label, null.ok = TRUE) |
| 627 | ||
| 628 | ! |
plot_args <- list(quote(ggplot2::ggplot(counts))) |
| 629 | ||
| 630 |
# aesthetic variables |
|
| 631 | ! |
x_val_var <- if (is.null(x_name)) 0 else x_name |
| 632 | ! |
plot_args <- c( |
| 633 | ! |
plot_args, |
| 634 | ! |
if (is.null(fill_name)) {
|
| 635 | ! |
bquote(ggplot2::aes(x = .data[[.(x_val_var)]])) |
| 636 |
} else {
|
|
| 637 | ! |
bquote(ggplot2::aes(x = .data[[.(x_val_var)]], fill = .data[[.(fill_name)]])) |
| 638 |
} |
|
| 639 |
) |
|
| 640 | ||
| 641 | ! |
if (!(is.null(x_facet_name) && is.null(y_facet_name))) {
|
| 642 |
# free_x is needed, otherwise when we facet on x and x-ticks are different for each facet value, |
|
| 643 |
# it will fit all possible x-ticks across all facet values into each facet panel |
|
| 644 | ! |
plot_args <- c(plot_args, bquote( |
| 645 | ! |
ggplot2::facet_grid(.(facet_grid_formula(x_facet_name, y_facet_name)), scales = .(facet_scales)) |
| 646 |
)) |
|
| 647 |
} |
|
| 648 | ||
| 649 |
# position stacking or dodging for bars and text |
|
| 650 | ! |
position <- if (is.null(fill_name) || (barlayout == "side_by_side")) {
|
| 651 |
# vjust = on top, i.e. don't place below when only one filling (i.e. nothing really stacked) |
|
| 652 | ! |
quote(ggplot2::position_dodge(0.9)) |
| 653 |
} else {
|
|
| 654 | ! |
quote(ggplot2::position_stack(vjust = 0.5)) |
| 655 |
} |
|
| 656 | ||
| 657 |
# draw bars |
|
| 658 | ! |
if (is.null(fill_name)) {
|
| 659 |
# nothing to put side-by-side, so put fill to one color only |
|
| 660 |
# setting color via aesthetics does not work for some reason (but x = 0 above works) |
|
| 661 | ! |
plot_args <- c(plot_args, bquote( |
| 662 | ! |
ggplot2::geom_col( |
| 663 | ! |
ggplot2::aes( |
| 664 | ! |
y = .data[[.(y_name)]] |
| 665 |
), |
|
| 666 | ! |
position = .(position), |
| 667 | ! |
fill = .(ifelse( |
| 668 | ! |
!is.null(getOption("ggplot2.discrete.colour")),
|
| 669 | ! |
getOption("ggplot2.discrete.colour")[1],
|
| 670 | ! |
"#b6cae9" |
| 671 |
)) |
|
| 672 |
) |
|
| 673 |
)) |
|
| 674 |
} else {
|
|
| 675 | ! |
plot_args <- c(plot_args, bquote( |
| 676 | ! |
ggplot2::geom_col(ggplot2::aes(y = .data[[.(y_name)]]), position = .(position)) |
| 677 |
)) |
|
| 678 |
} |
|
| 679 | ||
| 680 |
# draw numbers above bars |
|
| 681 | ! |
if (label_bars) {
|
| 682 |
# center text and move slightly to the top or to the right (depending on flip axes) |
|
| 683 |
# see https://stackoverflow.com/questions/7263849/what-do-hjust-and-vjust-do-when-making-a-plot-using-ggplot |
|
| 684 | ! |
if (isTRUE(flip_axis)) {
|
| 685 | ! |
hjust <- if (barlayout == "stacked") 0.5 else -1 # put above bars if not stacked |
| 686 | ! |
vjust <- 0.5 |
| 687 |
} else {
|
|
| 688 | ! |
hjust <- 0.5 |
| 689 | ! |
vjust <- if (barlayout == "stacked") 0.5 else -1 # put above bars if not stacked |
| 690 |
} |
|
| 691 | ||
| 692 | ! |
plot_args <- c(plot_args, bquote( |
| 693 | ! |
ggplot2::geom_text(ggplot2::aes(y = .data[[.(y_name)]], label = .data[[.(y_name)]]), |
| 694 | ! |
stat = "identity", |
| 695 | ! |
angle = .(if (rotate_bar_labels) 45 else 0), |
| 696 | ! |
position = .(position), |
| 697 |
# hjust, vjust are respective to position, i.e. top, center etc. alignment |
|
| 698 | ! |
hjust = .(hjust), vjust = .(vjust) |
| 699 |
) |
|
| 700 |
)) |
|
| 701 |
} |
|
| 702 | ||
| 703 |
# add legend for fill |
|
| 704 | ! |
if (!is.null(fill_name)) {
|
| 705 | ! |
plot_args <- c(plot_args, bquote( |
| 706 | ! |
ggplot2::guides(fill = ggplot2::guide_legend(title = column_annotation_label(counts, .(fill_name)))) |
| 707 |
)) |
|
| 708 |
} |
|
| 709 | ||
| 710 | ! |
if (isTRUE(flip_axis)) plot_args <- c(plot_args, quote(ggplot2::coord_flip())) |
| 711 | ||
| 712 | ! |
if (expand_y_range > 0) {
|
| 713 | ! |
plot_args <- c(plot_args, bquote(ggplot2::scale_y_continuous( |
| 714 | ! |
labels = scales::comma, |
| 715 | ! |
expand = ggplot2::expansion(c(0, .(expand_y_range))) |
| 716 |
))) |
|
| 717 |
} |
|
| 718 | ||
| 719 | ! |
if (isTRUE(rotate_x_label)) ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) |
| 720 | ! |
if (isTRUE(rotate_y_label)) ggplot2_args$theme[["axis.text.y"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) |
| 721 | ! |
if (!is.null(x_name)) {
|
| 722 | ! |
ggplot2_args$labs[["x"]] <- substitute( |
| 723 | ! |
expr = column_annotation_label(counts, x_name), |
| 724 | ! |
env = list(x_name = x_name) |
| 725 |
) |
|
| 726 |
} else {
|
|
| 727 | ! |
ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_blank()) |
| 728 | ! |
ggplot2_args$theme[["axis.ticks.x"]] <- quote(ggplot2::element_blank()) |
| 729 |
} |
|
| 730 | ||
| 731 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args) |
| 732 | ! |
plot_args <- c(plot_args, parsed_ggplot2_args) |
| 733 | ||
| 734 | ! |
bquote(plot <- .(call_concatenate(plot_args))) |
| 735 |
} |
|
| 736 | ||
| 737 |
# get name of column in "counts" data.frame |
|
| 738 |
get_n_name <- function(groupby_vars) {
|
|
| 739 | ! |
paste0("n_", paste(groupby_vars, collapse = "_"))
|
| 740 |
} |
|
| 741 | ||
| 742 |
# expression that counts by specified group |
|
| 743 |
# n_name: name of column to add counts to, by default determined from groupby_vars |
|
| 744 |
count_by_group_expr <- function(groupby_vars, data_name = "counts") {
|
|
| 745 | ! |
checkmate::assert_character(groupby_vars) |
| 746 | ! |
n_name <- get_n_name(groupby_vars) |
| 747 | ||
| 748 | ! |
parse( |
| 749 | ! |
text = sprintf( |
| 750 | ! |
"counts <- %s %%>%% dplyr::group_by(%s) %%>%% dplyr::mutate(%s = dplyr::n()) %%>%% dplyr::ungroup()", |
| 751 | ! |
data_name, |
| 752 | ! |
paste(groupby_vars, collapse = ","), |
| 753 | ! |
n_name |
| 754 |
), |
|
| 755 | ! |
keep.source = FALSE |
| 756 |
) |
|
| 757 |
} |
|
| 758 | ||
| 759 |
get_facet_scale <- function(x, y) {
|
|
| 760 | ! |
facet_scale_x <- if (isTRUE(x)) {
|
| 761 | ! |
"fixed" |
| 762 |
} else {
|
|
| 763 | ! |
"free" |
| 764 |
} |
|
| 765 | ! |
facet_scale_y <- if (isTRUE(y)) {
|
| 766 | ! |
"fixed" |
| 767 |
} else {
|
|
| 768 | ! |
"free" |
| 769 |
} |
|
| 770 | ||
| 771 | ! |
if (facet_scale_x == "fixed" && facet_scale_y == "free") {
|
| 772 | ! |
"free_y" |
| 773 | ! |
} else if (facet_scale_x == "free" && facet_scale_y == "fixed") {
|
| 774 | ! |
"free_x" |
| 775 |
} else {
|
|
| 776 | ! |
facet_scale_x # fixed or free, as x and y match |
| 777 |
} |
|
| 778 |
} |
| 1 |
#' Template: Response Forest Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a response forest plot. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams tern::g_forest |
|
| 6 |
#' @inheritParams template_arguments |
|
| 7 |
#' @param stats (`character`)\cr the names of statistics to be reported among: |
|
| 8 |
#' * `n`: Total number of observations per group. |
|
| 9 |
#' * `n_rsp`: Number of responders per group. |
|
| 10 |
#' * `prop`: Proportion of responders. |
|
| 11 |
#' * `n_tot`: Total number of observations. |
|
| 12 |
#' * `or`: Odds ratio. |
|
| 13 |
#' * `ci` : Confidence interval of odds ratio. |
|
| 14 |
#' * `pval`: p-value of the effect. |
|
| 15 |
#' Note, the statistics `n_tot`, `or`, and `ci` are required. |
|
| 16 |
#' @param riskdiff (`list`)\cr if a risk (proportion) difference column should be added, a list of settings to apply |
|
| 17 |
#' within the column. See [control_riskdiff()] for details. If `NULL`, no risk difference column will be added. |
|
| 18 |
#' @param obj_var_name (`character`)\cr additional text to append to the table title. |
|
| 19 |
#' @param responders (`character`)\cr values of `aval_var` that are considered to be responders. |
|
| 20 |
#' @param col_symbol_size (`integer` or `NULL`)\cr column index to be used to determine relative size for |
|
| 21 |
#' estimator plot symbol. Typically, the symbol size is proportional to the sample size used |
|
| 22 |
#' to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. |
|
| 23 |
#' @param strata_var (`character`)\cr names of the variables for stratified analysis. |
|
| 24 |
#' @param ggplot2_args (`ggplot2_args`) optional\cr |
|
| 25 |
#' object created by [teal.widgets::ggplot2_args()] with settings for the module plot. For this |
|
| 26 |
#' module, this argument will only accept `ggplot2_args` object with `labs` list of following child |
|
| 27 |
#' elements: `title`, `caption`. No other elements would be taken into account. The argument is |
|
| 28 |
#' merged with option `teal.ggplot2_args` and with default module arguments (hard coded in the module body). |
|
| 29 |
#' |
|
| 30 |
#' For more details, see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`.
|
|
| 31 |
#' |
|
| 32 |
#' @inherit template_arguments return |
|
| 33 |
#' |
|
| 34 |
#' @seealso [tm_g_forest_rsp()] |
|
| 35 |
#' |
|
| 36 |
#' @keywords internal |
|
| 37 |
template_forest_rsp <- function(dataname = "ANL", |
|
| 38 |
parentname = "ADSL", |
|
| 39 |
arm_var, |
|
| 40 |
ref_arm = NULL, |
|
| 41 |
comp_arm = NULL, |
|
| 42 |
obj_var_name = "", |
|
| 43 |
aval_var = "AVALC", |
|
| 44 |
responders = c("CR", "PR"),
|
|
| 45 |
subgroup_var, |
|
| 46 |
strata_var = NULL, |
|
| 47 |
stats = c("n_tot", "n", "n_rsp", "prop", "or", "ci"),
|
|
| 48 |
riskdiff = NULL, |
|
| 49 |
conf_level = 0.95, |
|
| 50 |
col_symbol_size = NULL, |
|
| 51 |
rel_width_forest = 0.25, |
|
| 52 |
font_size = 15, |
|
| 53 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 54 | 2x |
checkmate::assert_string(dataname) |
| 55 | 2x |
checkmate::assert_string(parentname) |
| 56 | 2x |
checkmate::assert_string(arm_var) |
| 57 | 2x |
checkmate::assert_string(aval_var) |
| 58 | 2x |
checkmate::assert_string(obj_var_name) |
| 59 | 2x |
checkmate::assert_character(subgroup_var, null.ok = TRUE) |
| 60 | 2x |
checkmate::assert_character(stats, min.len = 3) |
| 61 | 2x |
checkmate::assert_true(all(c("n_tot", "or", "ci") %in% stats))
|
| 62 | 2x |
checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 63 | 2x |
checkmate::assert_number(rel_width_forest, lower = 0, upper = 1) |
| 64 | 2x |
checkmate::assert_number(font_size) |
| 65 | ||
| 66 | 2x |
y <- list() |
| 67 | 2x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 68 | ||
| 69 |
# Data processing. |
|
| 70 | 2x |
data_list <- list() |
| 71 | 2x |
anl_list <- list() |
| 72 | 2x |
parent_list <- list() |
| 73 | ||
| 74 | 2x |
anl_list <- add_expr( |
| 75 | 2x |
anl_list, |
| 76 | 2x |
prepare_arm( |
| 77 | 2x |
dataname = dataname, |
| 78 | 2x |
arm_var = arm_var, |
| 79 | 2x |
ref_arm = ref_arm, |
| 80 | 2x |
comp_arm = comp_arm, |
| 81 | 2x |
ref_arm_val = ref_arm_val |
| 82 |
) |
|
| 83 |
) |
|
| 84 | ||
| 85 | 2x |
anl_list <- add_expr( |
| 86 | 2x |
anl_list, |
| 87 | 2x |
substitute( |
| 88 | 2x |
expr = dplyr::mutate(is_rsp = aval_var %in% responders), |
| 89 | 2x |
env = list( |
| 90 | 2x |
aval_var = as.name(aval_var), |
| 91 | 2x |
responders = responders |
| 92 |
) |
|
| 93 |
) |
|
| 94 |
) |
|
| 95 | ||
| 96 | 2x |
anl_list <- add_expr( |
| 97 | 2x |
anl_list, |
| 98 | 2x |
substitute_names( |
| 99 | 2x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = comp_arm)), |
| 100 | 2x |
names = list(arm_var = as.name(arm_var)), |
| 101 | 2x |
others = list(comp_arm = comp_arm) |
| 102 |
) |
|
| 103 |
) |
|
| 104 | ||
| 105 | 2x |
data_list <- add_expr( |
| 106 | 2x |
data_list, |
| 107 | 2x |
substitute( |
| 108 | 2x |
anl <- anl_list, |
| 109 | 2x |
env = list( |
| 110 | 2x |
anl = as.name(dataname), |
| 111 | 2x |
anl_list = pipe_expr(anl_list) |
| 112 |
) |
|
| 113 |
) |
|
| 114 |
) |
|
| 115 | ||
| 116 | 2x |
parent_list <- add_expr( |
| 117 | 2x |
parent_list, |
| 118 | 2x |
prepare_arm( |
| 119 | 2x |
dataname = parentname, |
| 120 | 2x |
arm_var = arm_var, |
| 121 | 2x |
ref_arm = ref_arm, |
| 122 | 2x |
comp_arm = comp_arm, |
| 123 | 2x |
ref_arm_val = ref_arm_val |
| 124 |
) |
|
| 125 |
) |
|
| 126 | ||
| 127 | 2x |
parent_list <- add_expr( |
| 128 | 2x |
parent_list, |
| 129 | 2x |
substitute_names( |
| 130 | 2x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = comp_arm)), |
| 131 | 2x |
names = list(arm_var = as.name(arm_var)), |
| 132 | 2x |
others = list(comp_arm = comp_arm) |
| 133 |
) |
|
| 134 |
) |
|
| 135 | ||
| 136 | 2x |
data_list <- add_expr( |
| 137 | 2x |
data_list, |
| 138 | 2x |
substitute( |
| 139 | 2x |
parent <- parent_list, |
| 140 | 2x |
env = list( |
| 141 | 2x |
parent_list = pipe_expr(parent_list) |
| 142 |
) |
|
| 143 |
) |
|
| 144 |
) |
|
| 145 | ||
| 146 | 2x |
y$data <- bracket_expr(data_list) |
| 147 | ||
| 148 |
# Tabulate subgroup analysis of response. |
|
| 149 | 2x |
summary_list <- list() |
| 150 | ||
| 151 | 2x |
summary_list <- add_expr( |
| 152 | 2x |
summary_list, |
| 153 | 2x |
substitute( |
| 154 | 2x |
expr = df <- extract_rsp_subgroups( |
| 155 | 2x |
variables = list( |
| 156 | 2x |
rsp = "is_rsp", arm = arm_var, subgroups = subgroup_var, strata = strata_var |
| 157 |
), |
|
| 158 | 2x |
data = anl, |
| 159 | 2x |
conf_level = conf_level |
| 160 |
), |
|
| 161 | 2x |
env = list( |
| 162 | 2x |
anl = as.name(dataname), |
| 163 | 2x |
arm_var = arm_var, |
| 164 | 2x |
subgroup_var = subgroup_var, |
| 165 | 2x |
strata_var = strata_var, |
| 166 | 2x |
conf_level = conf_level |
| 167 |
) |
|
| 168 |
) |
|
| 169 |
) |
|
| 170 | ||
| 171 | 2x |
y$summary <- bracket_expr(summary_list) |
| 172 | ||
| 173 |
# Table output. |
|
| 174 | 2x |
y$table <- substitute( |
| 175 | 2x |
expr = result <- rtables::basic_table() %>% |
| 176 | 2x |
tabulate_rsp_subgroups(df, vars = stats, riskdiff = riskdiff), |
| 177 | 2x |
env = list(stats = stats, riskdiff = riskdiff) |
| 178 |
) |
|
| 179 | ||
| 180 | 2x |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 181 | 2x |
user_plot = ggplot2_args, |
| 182 | 2x |
module_plot = teal.widgets::ggplot2_args( |
| 183 | 2x |
labs = list( |
| 184 | 2x |
title = paste("Forest Plot of Best Overall Response for", obj_var_name),
|
| 185 | 2x |
caption = "" |
| 186 |
) |
|
| 187 |
) |
|
| 188 |
) |
|
| 189 | ||
| 190 | 2x |
plot_list <- list() |
| 191 | ||
| 192 | 2x |
plot_list <- add_expr( |
| 193 | 2x |
plot_list, |
| 194 | 2x |
substitute( |
| 195 | 2x |
expr = {
|
| 196 | ! |
f <- g_forest( |
| 197 | ! |
tbl = result, |
| 198 | ! |
col_symbol_size = col_s_size, |
| 199 | ! |
font_size = font_size, |
| 200 | ! |
as_list = TRUE |
| 201 |
) |
|
| 202 |
}, |
|
| 203 | 2x |
env = list( |
| 204 | 2x |
col_s_size = col_symbol_size, |
| 205 | 2x |
font_size = font_size |
| 206 |
) |
|
| 207 |
) |
|
| 208 |
) |
|
| 209 | ||
| 210 | 2x |
plot_list <- add_expr( |
| 211 | 2x |
plot_list, |
| 212 | 2x |
substitute( |
| 213 | 2x |
expr = {
|
| 214 | ! |
p <- cowplot::plot_grid( |
| 215 | ! |
f[["table"]] + ggplot2::labs(title = ggplot2_args_title), |
| 216 | ! |
f[["plot"]] + ggplot2::labs(caption = ggplot2_args_caption), |
| 217 | ! |
align = "h", |
| 218 | ! |
axis = "tblr", |
| 219 | ! |
rel_widths = c(1 - rel_width_forest, rel_width_forest) |
| 220 |
) |
|
| 221 |
}, |
|
| 222 | 2x |
env = list( |
| 223 | 2x |
rel_width_forest = rel_width_forest, |
| 224 | 2x |
ggplot2_args_title = all_ggplot2_args$labs$title, |
| 225 | 2x |
ggplot2_args_caption = all_ggplot2_args$labs$caption |
| 226 |
) |
|
| 227 |
) |
|
| 228 |
) |
|
| 229 | ||
| 230 |
# Plot output. |
|
| 231 | 2x |
y$plot <- plot_list |
| 232 | ||
| 233 | 2x |
y |
| 234 |
} |
|
| 235 | ||
| 236 |
#' teal Module: Forest Response Plot |
|
| 237 |
#' |
|
| 238 |
#' This module produces a grid-style forest plot for response data with ADaM structure. |
|
| 239 |
#' |
|
| 240 |
#' @inheritParams tern::g_forest |
|
| 241 |
#' @inheritParams module_arguments |
|
| 242 |
#' @inheritParams template_forest_rsp |
|
| 243 |
#' |
|
| 244 |
#' @inherit module_arguments return seealso |
|
| 245 |
#' |
|
| 246 |
#' @examples |
|
| 247 |
#' library(nestcolor) |
|
| 248 |
#' library(dplyr) |
|
| 249 |
#' |
|
| 250 |
#' ADSL <- tmc_ex_adsl |
|
| 251 |
#' ADRS <- tmc_ex_adrs %>% |
|
| 252 |
#' mutate(AVALC = d_onco_rsp_label(AVALC) %>% |
|
| 253 |
#' with_label("Character Result/Finding")) %>%
|
|
| 254 |
#' filter(PARAMCD != "OVRINV" | AVISIT == "FOLLOW UP") |
|
| 255 |
#' |
|
| 256 |
#' arm_ref_comp <- list( |
|
| 257 |
#' ARM = list( |
|
| 258 |
#' ref = "B: Placebo", |
|
| 259 |
#' comp = c("A: Drug X", "C: Combination")
|
|
| 260 |
#' ), |
|
| 261 |
#' ARMCD = list( |
|
| 262 |
#' ref = "ARM B", |
|
| 263 |
#' comp = c("ARM A", "ARM C")
|
|
| 264 |
#' ) |
|
| 265 |
#' ) |
|
| 266 |
#' |
|
| 267 |
#' app <- init( |
|
| 268 |
#' data = cdisc_data( |
|
| 269 |
#' ADSL = ADSL, |
|
| 270 |
#' ADRS = ADRS, |
|
| 271 |
#' code = " |
|
| 272 |
#' ADSL <- tmc_ex_adsl |
|
| 273 |
#' ADRS <- tmc_ex_adrs %>% |
|
| 274 |
#' mutate(AVALC = d_onco_rsp_label(AVALC) %>% |
|
| 275 |
#' with_label(\"Character Result/Finding\")) %>% |
|
| 276 |
#' filter(PARAMCD != \"OVRINV\" | AVISIT == \"FOLLOW UP\") |
|
| 277 |
#' " |
|
| 278 |
#' ), |
|
| 279 |
#' modules = modules( |
|
| 280 |
#' tm_g_forest_rsp( |
|
| 281 |
#' label = "Forest Response", |
|
| 282 |
#' dataname = "ADRS", |
|
| 283 |
#' arm_var = choices_selected( |
|
| 284 |
#' variable_choices(ADSL, c("ARM", "ARMCD")),
|
|
| 285 |
#' "ARMCD" |
|
| 286 |
#' ), |
|
| 287 |
#' arm_ref_comp = arm_ref_comp, |
|
| 288 |
#' paramcd = choices_selected( |
|
| 289 |
#' value_choices(ADRS, "PARAMCD", "PARAM"), |
|
| 290 |
#' "INVET" |
|
| 291 |
#' ), |
|
| 292 |
#' subgroup_var = choices_selected( |
|
| 293 |
#' variable_choices(ADSL, names(ADSL)), |
|
| 294 |
#' c("BMRKR2", "SEX")
|
|
| 295 |
#' ), |
|
| 296 |
#' strata_var = choices_selected( |
|
| 297 |
#' variable_choices(ADSL, c("STRATA1", "STRATA2")),
|
|
| 298 |
#' "STRATA2" |
|
| 299 |
#' ), |
|
| 300 |
#' plot_height = c(600L, 200L, 2000L), |
|
| 301 |
#' default_responses = list( |
|
| 302 |
#' BESRSPI = list( |
|
| 303 |
#' rsp = c("Stable Disease (SD)", "Not Evaluable (NE)"),
|
|
| 304 |
#' levels = c( |
|
| 305 |
#' "Complete Response (CR)", "Partial Response (PR)", "Stable Disease (SD)", |
|
| 306 |
#' "Progressive Disease (PD)", "Not Evaluable (NE)" |
|
| 307 |
#' ) |
|
| 308 |
#' ), |
|
| 309 |
#' INVET = list( |
|
| 310 |
#' rsp = c("Complete Response (CR)", "Partial Response (PR)"),
|
|
| 311 |
#' levels = c( |
|
| 312 |
#' "Complete Response (CR)", "Not Evaluable (NE)", "Partial Response (PR)", |
|
| 313 |
#' "Progressive Disease (PD)", "Stable Disease (SD)" |
|
| 314 |
#' ) |
|
| 315 |
#' ), |
|
| 316 |
#' OVRINV = list( |
|
| 317 |
#' rsp = c("Progressive Disease (PD)", "Stable Disease (SD)"),
|
|
| 318 |
#' levels = c("Progressive Disease (PD)", "Stable Disease (SD)", "Not Evaluable (NE)")
|
|
| 319 |
#' ) |
|
| 320 |
#' ) |
|
| 321 |
#' ) |
|
| 322 |
#' ) |
|
| 323 |
#' ) |
|
| 324 |
#' if (interactive()) {
|
|
| 325 |
#' shinyApp(app$ui, app$server) |
|
| 326 |
#' } |
|
| 327 |
#' |
|
| 328 |
#' @export |
|
| 329 |
tm_g_forest_rsp <- function(label, |
|
| 330 |
dataname, |
|
| 331 |
parentname = ifelse( |
|
| 332 |
inherits(arm_var, "data_extract_spec"), |
|
| 333 |
teal.transform::datanames_input(arm_var), |
|
| 334 |
"ADSL" |
|
| 335 |
), |
|
| 336 |
arm_var, |
|
| 337 |
arm_ref_comp = NULL, |
|
| 338 |
paramcd, |
|
| 339 |
aval_var = teal.transform::choices_selected( |
|
| 340 |
teal.transform::variable_choices(dataname, "AVALC"), "AVALC", |
|
| 341 |
fixed = TRUE |
|
| 342 |
), |
|
| 343 |
subgroup_var, |
|
| 344 |
strata_var, |
|
| 345 |
stats = c("n_tot", "n", "n_rsp", "prop", "or", "ci"),
|
|
| 346 |
riskdiff = NULL, |
|
| 347 |
fixed_symbol_size = TRUE, |
|
| 348 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 349 |
default_responses = c("CR", "PR", "Y", "Complete Response (CR)", "Partial Response (PR)"),
|
|
| 350 |
plot_height = c(500L, 200L, 2000L), |
|
| 351 |
plot_width = c(1500L, 800L, 3000L), |
|
| 352 |
rel_width_forest = c(25L, 0L, 100L), |
|
| 353 |
font_size = c(15L, 1L, 30L), |
|
| 354 |
pre_output = NULL, |
|
| 355 |
post_output = NULL, |
|
| 356 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 357 | ! |
message("Initializing tm_g_forest_rsp")
|
| 358 | ! |
checkmate::assert_string(label) |
| 359 | ! |
checkmate::assert_string(dataname) |
| 360 | ! |
checkmate::assert_string(parentname) |
| 361 | ! |
checkmate::assert_flag(fixed_symbol_size) |
| 362 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 363 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 364 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 365 | ! |
checkmate::assert_class(subgroup_var, "choices_selected") |
| 366 | ! |
checkmate::assert_class(strata_var, "choices_selected") |
| 367 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 368 | ! |
checkmate::assert_character(stats, min.len = 3) |
| 369 | ! |
checkmate::assert_true(all(c("n_tot", "or", "ci") %in% stats))
|
| 370 | ! |
checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 371 | ! |
checkmate::assert_multi_class(default_responses, c("list", "character", "numeric"), null.ok = TRUE)
|
| 372 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 373 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 374 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 375 | ! |
checkmate::assert_numeric( |
| 376 | ! |
plot_width[1], |
| 377 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 378 |
) |
|
| 379 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 380 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 381 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 382 | ||
| 383 | ! |
args <- as.list(environment()) |
| 384 | ||
| 385 | ! |
data_extract_list <- list( |
| 386 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 387 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 388 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 389 | ! |
subgroup_var = cs_to_des_select(subgroup_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 390 | ! |
strata_var = cs_to_des_select(strata_var, dataname = parentname, multiple = TRUE) |
| 391 |
) |
|
| 392 | ||
| 393 | ! |
module( |
| 394 | ! |
label = label, |
| 395 | ! |
ui = ui_g_forest_rsp, |
| 396 | ! |
ui_args = c(data_extract_list, args), |
| 397 | ! |
server = srv_g_forest_rsp, |
| 398 | ! |
server_args = c( |
| 399 | ! |
data_extract_list, |
| 400 | ! |
list( |
| 401 | ! |
dataname = dataname, |
| 402 | ! |
parentname = parentname, |
| 403 | ! |
arm_ref_comp = arm_ref_comp, |
| 404 | ! |
label = label, |
| 405 | ! |
stats = stats, |
| 406 | ! |
riskdiff = riskdiff, |
| 407 | ! |
default_responses = default_responses, |
| 408 | ! |
plot_height = plot_height, |
| 409 | ! |
plot_width = plot_width, |
| 410 | ! |
ggplot2_args = ggplot2_args |
| 411 |
) |
|
| 412 |
), |
|
| 413 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 414 |
) |
|
| 415 |
} |
|
| 416 | ||
| 417 |
#' @keywords internal |
|
| 418 |
ui_g_forest_rsp <- function(id, ...) {
|
|
| 419 | ! |
a <- list(...) # module args |
| 420 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset(a$arm_var, a$paramcd, a$subgroup_var, a$strata_var) |
| 421 | ||
| 422 | ! |
ns <- NS(id) |
| 423 | ||
| 424 | ! |
teal.widgets::standard_layout( |
| 425 | ! |
output = teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 426 | ! |
encoding = tags$div( |
| 427 |
### Reporter |
|
| 428 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 429 |
### |
|
| 430 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 431 | ! |
teal.transform::datanames_input(a[c("arm_var", "paramcd", "aval_var", "subgroup_var", "strata_var")]),
|
| 432 | ! |
teal.transform::data_extract_ui( |
| 433 | ! |
id = ns("paramcd"),
|
| 434 | ! |
label = "Select Endpoint", |
| 435 | ! |
data_extract_spec = a$paramcd, |
| 436 | ! |
is_single_dataset = is_single_dataset_value |
| 437 |
), |
|
| 438 | ! |
teal.transform::data_extract_ui( |
| 439 | ! |
id = ns("aval_var"),
|
| 440 | ! |
label = "Analysis Variable", |
| 441 | ! |
data_extract_spec = a$aval_var, |
| 442 | ! |
is_single_dataset = is_single_dataset_value |
| 443 |
), |
|
| 444 | ! |
selectInput( |
| 445 | ! |
ns("responders"),
|
| 446 | ! |
"Responders", |
| 447 | ! |
choices = c("CR", "PR"),
|
| 448 | ! |
selected = c("CR", "PR"),
|
| 449 | ! |
multiple = TRUE |
| 450 |
), |
|
| 451 | ! |
teal.transform::data_extract_ui( |
| 452 | ! |
id = ns("arm_var"),
|
| 453 | ! |
label = "Select Treatment Variable", |
| 454 | ! |
data_extract_spec = a$arm_var, |
| 455 | ! |
is_single_dataset = is_single_dataset_value |
| 456 |
), |
|
| 457 | ! |
uiOutput( |
| 458 | ! |
ns("arms_buckets"),
|
| 459 | ! |
title = paste( |
| 460 | ! |
"Multiple reference groups are automatically combined into a single group when more than one", |
| 461 | ! |
"value is selected." |
| 462 |
) |
|
| 463 |
), |
|
| 464 | ! |
teal.transform::data_extract_ui( |
| 465 | ! |
id = ns("subgroup_var"),
|
| 466 | ! |
label = "Subgroup Variables", |
| 467 | ! |
data_extract_spec = a$subgroup_var, |
| 468 | ! |
is_single_dataset = is_single_dataset_value |
| 469 |
), |
|
| 470 | ! |
teal.transform::data_extract_ui( |
| 471 | ! |
id = ns("strata_var"),
|
| 472 | ! |
label = "Stratify by", |
| 473 | ! |
data_extract_spec = a$strata_var, |
| 474 | ! |
is_single_dataset = is_single_dataset_value |
| 475 |
), |
|
| 476 | ! |
teal.widgets::panel_group( |
| 477 | ! |
teal.widgets::panel_item( |
| 478 | ! |
"Additional plot settings", |
| 479 | ! |
teal.widgets::optionalSelectInput( |
| 480 | ! |
inputId = ns("conf_level"),
|
| 481 | ! |
label = "Confidence Level", |
| 482 | ! |
a$conf_level$choices, |
| 483 | ! |
a$conf_level$selected, |
| 484 | ! |
multiple = FALSE, |
| 485 | ! |
fixed = a$conf_level$fixed |
| 486 |
), |
|
| 487 | ! |
checkboxInput(ns("fixed_symbol_size"), "Fixed symbol size", value = TRUE),
|
| 488 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 489 | ! |
ns("rel_width_forest"),
|
| 490 | ! |
"Relative Width of Forest Plot (%)", |
| 491 | ! |
a$rel_width_forest, |
| 492 | ! |
ticks = FALSE, step = 1 |
| 493 |
), |
|
| 494 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 495 | ! |
ns("font_size"),
|
| 496 | ! |
"Table Font Size", |
| 497 | ! |
a$font_size, |
| 498 | ! |
ticks = FALSE, step = 1 |
| 499 |
) |
|
| 500 |
) |
|
| 501 |
) |
|
| 502 |
), |
|
| 503 | ! |
forms = tagList( |
| 504 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 505 |
), |
|
| 506 | ! |
pre_output = a$pre_output, |
| 507 | ! |
post_output = a$post_output |
| 508 |
) |
|
| 509 |
} |
|
| 510 | ||
| 511 |
#' @keywords internal |
|
| 512 |
srv_g_forest_rsp <- function(id, |
|
| 513 |
data, |
|
| 514 |
reporter, |
|
| 515 |
filter_panel_api, |
|
| 516 |
dataname, |
|
| 517 |
parentname, |
|
| 518 |
arm_var, |
|
| 519 |
arm_ref_comp, |
|
| 520 |
paramcd, |
|
| 521 |
aval_var, |
|
| 522 |
subgroup_var, |
|
| 523 |
strata_var, |
|
| 524 |
stats, |
|
| 525 |
riskdiff, |
|
| 526 |
plot_height, |
|
| 527 |
plot_width, |
|
| 528 |
label, |
|
| 529 |
default_responses, |
|
| 530 |
ggplot2_args) {
|
|
| 531 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 532 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 533 | ! |
checkmate::assert_class(data, "reactive") |
| 534 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 535 | ||
| 536 | ! |
moduleServer(id, function(input, output, session) {
|
| 537 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 538 |
# Setup arm variable selection, default reference arms, and default |
|
| 539 |
# comparison arms for encoding panel |
|
| 540 | ! |
iv_arm_ref <- arm_ref_comp_observer( |
| 541 | ! |
session, |
| 542 | ! |
input, |
| 543 | ! |
output, |
| 544 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 545 | ! |
data = data()[[parentname]], |
| 546 | ! |
arm_ref_comp = arm_ref_comp, |
| 547 | ! |
module = "tm_t_tte" |
| 548 |
) |
|
| 549 | ||
| 550 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 551 | ! |
data_extract = list( |
| 552 | ! |
arm_var = arm_var, |
| 553 | ! |
subgroup_var = subgroup_var, |
| 554 | ! |
strata_var = strata_var, |
| 555 | ! |
paramcd = paramcd, |
| 556 | ! |
aval_var = aval_var |
| 557 |
), |
|
| 558 | ! |
datasets = data, |
| 559 | ! |
select_validation_rule = list( |
| 560 | ! |
aval_var = shinyvalidate::sv_required("An analysis variable is required"),
|
| 561 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required")
|
| 562 |
), |
|
| 563 | ! |
filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select Endpoint filter.")) |
| 564 |
) |
|
| 565 | ||
| 566 | ! |
iv_r <- reactive({
|
| 567 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 568 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level between 0 and 1"))
|
| 569 | ! |
iv$add_rule( |
| 570 | ! |
"conf_level", |
| 571 | ! |
shinyvalidate::sv_between(0, 1, message_fmt = "Please choose a confidence level between {left} and {right}")
|
| 572 |
) |
|
| 573 | ! |
iv$add_rule("responders", shinyvalidate::sv_required("`Responders` field is empty"))
|
| 574 | ! |
iv$add_validator(iv_arm_ref) |
| 575 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list, c("arm_var", "aval_var", "paramcd"))
|
| 576 |
}) |
|
| 577 | ||
| 578 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 579 | ! |
datasets = data, |
| 580 | ! |
selector_list = selector_list, |
| 581 | ! |
merge_function = "dplyr::inner_join" |
| 582 |
) |
|
| 583 | ||
| 584 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 585 | ! |
datasets = data, |
| 586 | ! |
data_extract = list(arm_var = arm_var, subgroup_var = subgroup_var, strata_var = strata_var), |
| 587 | ! |
anl_name = "ANL_ADSL" |
| 588 |
) |
|
| 589 | ||
| 590 | ! |
anl_q <- reactive({
|
| 591 | ! |
data() %>% |
| 592 | ! |
teal.code::eval_code(code = as.expression(anl_inputs()$expr)) %>% |
| 593 | ! |
teal.code::eval_code(code = as.expression(adsl_inputs()$expr)) |
| 594 |
}) |
|
| 595 | ||
| 596 | ! |
observeEvent( |
| 597 | ! |
eventExpr = c( |
| 598 | ! |
input[[extract_input("aval_var", "ADRS")]],
|
| 599 | ! |
input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]]
|
| 600 |
), |
|
| 601 | ! |
handlerExpr = {
|
| 602 | ! |
req(anl_q()) |
| 603 | ! |
anl <- anl_q()[["ANL"]] |
| 604 | ! |
aval_var <- anl_inputs()$columns_source$aval_var |
| 605 | ! |
paramcd_level <- unlist(anl_inputs()$filter_info$paramcd[[1]]$selected) |
| 606 | ! |
if (length(paramcd_level) == 0) {
|
| 607 | ! |
return(NULL) |
| 608 |
} |
|
| 609 | ||
| 610 | ! |
sel_param <- if (is.list(default_responses)) {
|
| 611 | ! |
default_responses[[paramcd_level]] |
| 612 |
} else {
|
|
| 613 | ! |
default_responses |
| 614 |
} |
|
| 615 | ||
| 616 | ||
| 617 | ! |
common_rsp <- if (is.list(sel_param)) {
|
| 618 | ! |
sel_param$rsp |
| 619 |
} else {
|
|
| 620 | ! |
sel_param |
| 621 |
} |
|
| 622 | ! |
responder_choices <- if (length(aval_var) == 0) {
|
| 623 | ! |
character(0) |
| 624 |
} else {
|
|
| 625 | ! |
if ("levels" %in% names(sel_param)) {
|
| 626 | ! |
if (length(intersect(unique(anl[[aval_var]]), sel_param$levels)) > 1) {
|
| 627 | ! |
sel_param$levels |
| 628 |
} else {
|
|
| 629 | ! |
union(anl[[aval_var]], sel_param$levels) |
| 630 |
} |
|
| 631 |
} else {
|
|
| 632 | ! |
unique(anl[[aval_var]]) |
| 633 |
} |
|
| 634 |
} |
|
| 635 | ! |
updateSelectInput( |
| 636 | ! |
session, "responders", |
| 637 | ! |
choices = responder_choices, |
| 638 | ! |
selected = intersect(responder_choices, common_rsp) |
| 639 |
) |
|
| 640 |
} |
|
| 641 |
) |
|
| 642 | ||
| 643 |
# Prepare the analysis environment (filter data, check data, populate envir). |
|
| 644 | ! |
validate_checks <- reactive({
|
| 645 | ! |
teal::validate_inputs(iv_r()) |
| 646 | ! |
req(anl_q()) |
| 647 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 648 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 649 | ! |
anl <- anl_q()[["ANL"]] |
| 650 | ||
| 651 | ! |
anl_m <- anl_inputs() |
| 652 | ! |
input_arm_var <- as.vector(anl_m$columns_source$arm_var) |
| 653 | ! |
input_aval_var <- as.vector(anl_m$columns_source$aval_var) |
| 654 | ! |
input_subgroup_var <- as.vector(anl_m$columns_source$subgroup_var) |
| 655 | ! |
input_strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 656 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 657 | ||
| 658 |
# validate inputs |
|
| 659 | ! |
validate_args <- list( |
| 660 | ! |
adsl = adsl_filtered, |
| 661 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var, input_subgroup_var, input_strata_var),
|
| 662 | ! |
anl = anl_filtered, |
| 663 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_aval_var),
|
| 664 | ! |
arm_var = input_arm_var |
| 665 |
) |
|
| 666 | ! |
validate_args <- append( |
| 667 | ! |
validate_args, |
| 668 | ! |
list(ref_arm = unlist(input$buckets$Ref), comp_arm = unlist(input$buckets$Comp)) |
| 669 |
) |
|
| 670 | ||
| 671 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 672 | ||
| 673 | ! |
teal::validate_one_row_per_id(anl_q()[["ANL"]], key = c("USUBJID", "STUDYID", input_paramcd))
|
| 674 | ||
| 675 | ! |
if (length(input_subgroup_var) > 0) {
|
| 676 | ! |
validate( |
| 677 | ! |
need( |
| 678 | ! |
all(vapply(adsl_filtered[, input_subgroup_var], is.factor, logical(1))), |
| 679 | ! |
"Not all subgroup variables are factors." |
| 680 |
) |
|
| 681 |
) |
|
| 682 |
} |
|
| 683 | ! |
if (length(input_strata_var) > 0) {
|
| 684 | ! |
validate( |
| 685 | ! |
need( |
| 686 | ! |
all(vapply(adsl_filtered[, input_strata_var], is.factor, logical(1))), |
| 687 | ! |
"Not all stratification variables are factors." |
| 688 |
) |
|
| 689 |
) |
|
| 690 |
} |
|
| 691 | ||
| 692 | ! |
if (!identical(default_responses, c("CR", "PR", "Y", "Complete Response (CR)", "Partial Response (PR)"))) {
|
| 693 | ! |
validate( |
| 694 | ! |
need( |
| 695 | ! |
all(unlist(lapply(default_responses, function(x) {
|
| 696 | ! |
if (is.list(x) & "levels" %in% names(x)) {
|
| 697 | ! |
lvls <- x$levels |
| 698 | ! |
all(x$rsp %in% lvls) |
| 699 |
} else {
|
|
| 700 | ! |
lvls <- unique(anl[[input$`aval_var-dataset_ADRS_singleextract-select`]]) |
| 701 | ! |
if ("rsp" %in% names(x)) {
|
| 702 | ! |
all(x$rsp %in% lvls) |
| 703 |
} else {
|
|
| 704 | ! |
all(x %in% lvls) |
| 705 |
} |
|
| 706 |
} |
|
| 707 |
}))), |
|
| 708 | ! |
"All selected default responses must be in the levels of AVAL." |
| 709 |
) |
|
| 710 |
) |
|
| 711 |
} |
|
| 712 | ||
| 713 | ! |
if (is.list(default_responses)) {
|
| 714 | ! |
validate( |
| 715 | ! |
need( |
| 716 | ! |
all( |
| 717 | ! |
grepl("\\.rsp|\\.levels", names(unlist(default_responses))) |
|
| 718 | ! |
names(unlist(default_responses)) %in% names(default_responses) |
| 719 |
), |
|
| 720 | ! |
"The lists given for each AVAL in default_responses must be named 'rsp' and 'levels'." |
| 721 |
) |
|
| 722 |
) |
|
| 723 |
} |
|
| 724 | ||
| 725 | ! |
validate_has_data(anl_q()[["ANL"]], min_nrow = 1) |
| 726 | ! |
NULL |
| 727 |
}) |
|
| 728 | ||
| 729 |
# The R-code corresponding to the analysis. |
|
| 730 | ! |
all_q <- reactive({
|
| 731 | ! |
validate_checks() |
| 732 | ! |
anl_m <- anl_inputs() |
| 733 | ||
| 734 | ! |
strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 735 | ! |
subgroup_var <- as.vector(anl_m$columns_source$subgroup_var) |
| 736 | ||
| 737 | ! |
obj_var_name <- get_g_forest_obj_var_name(paramcd, input) |
| 738 | ||
| 739 | ! |
my_calls <- template_forest_rsp( |
| 740 | ! |
dataname = "ANL", |
| 741 | ! |
parentname = "ANL_ADSL", |
| 742 | ! |
arm_var = as.vector(anl_m$columns_source$arm_var), |
| 743 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 744 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 745 | ! |
obj_var_name = obj_var_name, |
| 746 | ! |
aval_var = as.vector(anl_m$columns_source$aval_var), |
| 747 | ! |
responders = input$responders, |
| 748 | ! |
subgroup_var = if (length(subgroup_var) != 0) subgroup_var else NULL, |
| 749 | ! |
strata_var = if (length(strata_var) != 0) strata_var else NULL, |
| 750 | ! |
stats = stats, |
| 751 | ! |
riskdiff = riskdiff, |
| 752 | ! |
conf_level = as.numeric(input$conf_level), |
| 753 | ! |
col_symbol_size = `if`(input$fixed_symbol_size, NULL, 1), |
| 754 | ! |
rel_width_forest = input$rel_width_forest / 100, |
| 755 | ! |
font_size = input$font_size, |
| 756 | ! |
ggplot2_args = ggplot2_args |
| 757 |
) |
|
| 758 | ||
| 759 | ! |
teal.code::eval_code(anl_q(), as.expression(my_calls)) |
| 760 |
}) |
|
| 761 | ||
| 762 | ! |
plot_r <- reactive(all_q()[["p"]]) |
| 763 | ||
| 764 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 765 | ! |
id = "myplot", |
| 766 | ! |
plot_r = plot_r, |
| 767 | ! |
height = plot_height, |
| 768 | ! |
width = plot_width |
| 769 |
) |
|
| 770 | ||
| 771 | ! |
teal.widgets::verbatim_popup_srv( |
| 772 | ! |
id = "rcode", |
| 773 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 774 | ! |
title = label |
| 775 |
) |
|
| 776 | ||
| 777 |
### REPORTER |
|
| 778 | ! |
if (with_reporter) {
|
| 779 | ! |
card_fun <- function(comment, label) {
|
| 780 | ! |
card <- teal::report_card_template( |
| 781 | ! |
title = "Forest Response Plot", |
| 782 | ! |
label = label, |
| 783 | ! |
with_filter = with_filter, |
| 784 | ! |
filter_panel_api = filter_panel_api |
| 785 |
) |
|
| 786 | ! |
card$append_text("Plot", "header3")
|
| 787 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 788 | ! |
if (!comment == "") {
|
| 789 | ! |
card$append_text("Comment", "header3")
|
| 790 | ! |
card$append_text(comment) |
| 791 |
} |
|
| 792 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 793 | ! |
card |
| 794 |
} |
|
| 795 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 796 |
} |
|
| 797 |
### |
|
| 798 |
}) |
|
| 799 |
} |
| 1 |
#' Template: Summarize Variables by Row Groups Module |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table to summarize variables by row groups. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param parallel_vars (`logical`)\cr whether summarized variables should be arranged in columns. Can only be set to |
|
| 7 |
#' `TRUE` if all chosen analysis variables are numeric. |
|
| 8 |
#' @param row_groups (`logical`)\cr whether summarized variables should be arranged in row groups. |
|
| 9 |
#' @param drop_zero_levels (`logical`)\cr whether rows with zero counts in all columns should be removed from the table. |
|
| 10 |
#' |
|
| 11 |
#' @inherit template_arguments return |
|
| 12 |
#' |
|
| 13 |
#' @seealso [tm_t_summary_by()] |
|
| 14 |
#' |
|
| 15 |
#' @keywords internal |
|
| 16 |
template_summary_by <- function(parentname, |
|
| 17 |
dataname, |
|
| 18 |
arm_var, |
|
| 19 |
id_var, |
|
| 20 |
sum_vars, |
|
| 21 |
by_vars, |
|
| 22 |
var_labels = character(), |
|
| 23 |
add_total = TRUE, |
|
| 24 |
total_label = default_total_label(), |
|
| 25 |
parallel_vars = FALSE, |
|
| 26 |
row_groups = FALSE, |
|
| 27 |
na.rm = FALSE, # nolint: object_name. |
|
| 28 |
na_level = default_na_str(), |
|
| 29 |
numeric_stats = c( |
|
| 30 |
"n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", "range" |
|
| 31 |
), |
|
| 32 |
denominator = c("N", "n", "omit"),
|
|
| 33 |
drop_arm_levels = TRUE, |
|
| 34 |
drop_zero_levels = TRUE, |
|
| 35 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 36 | 5x |
checkmate::assert_string(parentname) |
| 37 | 5x |
checkmate::assert_string(dataname) |
| 38 | 5x |
checkmate::assert_string(id_var) |
| 39 | 5x |
checkmate::assert_character(sum_vars) |
| 40 | 5x |
checkmate::assert_character(by_vars) |
| 41 | 5x |
checkmate::assert_character(var_labels) |
| 42 | 5x |
checkmate::assert_flag(add_total) |
| 43 | 5x |
checkmate::assert_string(total_label) |
| 44 | 5x |
checkmate::assert_flag(parallel_vars) |
| 45 | 5x |
checkmate::assert_flag(row_groups) |
| 46 | 5x |
checkmate::assert_flag(na.rm) |
| 47 | 5x |
checkmate::assert_string(na_level) |
| 48 | 5x |
checkmate::assert_flag(drop_arm_levels) |
| 49 | 5x |
checkmate::assert_character(numeric_stats) |
| 50 | 5x |
checkmate::assert_flag(drop_zero_levels) |
| 51 | 5x |
checkmate::assert_character(arm_var, min.len = 1, max.len = 2) |
| 52 | ||
| 53 | 5x |
denominator <- match.arg(denominator) |
| 54 | ||
| 55 | 5x |
y <- list() |
| 56 | ||
| 57 |
# Data processing |
|
| 58 | 5x |
data_list <- list() |
| 59 | ||
| 60 | 5x |
data_list <- add_expr( |
| 61 | 5x |
data_list, |
| 62 | 5x |
substitute( |
| 63 | 5x |
expr = anl <- df %>% |
| 64 | 5x |
df_explicit_na(omit_columns = setdiff(names(df), c(by_vars, sum_vars)), na_level = na_str), |
| 65 | 5x |
env = list( |
| 66 | 5x |
df = as.name(dataname), |
| 67 | 5x |
by_vars = by_vars, |
| 68 | 5x |
sum_vars = sum_vars, |
| 69 | 5x |
na_str = na_level |
| 70 |
) |
|
| 71 |
) |
|
| 72 |
) |
|
| 73 | ||
| 74 | 5x |
prepare_arm_levels_call <- lapply(arm_var, function(x) {
|
| 75 | 5x |
prepare_arm_levels( |
| 76 | 5x |
dataname = "anl", |
| 77 | 5x |
parentname = parentname, |
| 78 | 5x |
arm_var = x, |
| 79 | 5x |
drop_arm_levels = drop_arm_levels |
| 80 |
) |
|
| 81 |
}) |
|
| 82 | 5x |
data_list <- Reduce(add_expr, prepare_arm_levels_call, init = data_list) |
| 83 | ||
| 84 | 5x |
data_list <- add_expr( |
| 85 | 5x |
data_list, |
| 86 | 5x |
substitute( |
| 87 | 5x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 88 | 5x |
env = list(parentname = as.name(parentname), na_str = na_level) |
| 89 |
) |
|
| 90 |
) |
|
| 91 | ||
| 92 | 5x |
y$data <- bracket_expr(data_list) |
| 93 | ||
| 94 |
# Build layout |
|
| 95 | 5x |
y$layout_prep <- quote(split_fun <- drop_split_levels) |
| 96 | 5x |
if (row_groups) {
|
| 97 | 1x |
y$layout_cfun <- quote( |
| 98 | 1x |
cfun_unique <- function(x, labelstr = "", .N_col) { # nolint: object_name.
|
| 99 | ! |
y <- length(unique(x)) |
| 100 | ! |
rcell( |
| 101 | ! |
c(y, y / .N_col), |
| 102 | ! |
label = labelstr |
| 103 |
) |
|
| 104 |
} |
|
| 105 |
) |
|
| 106 |
} |
|
| 107 | ||
| 108 | 5x |
table_title <- paste("Summary Table for", paste(sum_vars, collapse = ", "), "by", paste(by_vars, collapse = ", "))
|
| 109 | ||
| 110 | 5x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 111 | 5x |
teal.widgets::resolve_basic_table_args( |
| 112 | 5x |
user_table = basic_table_args, |
| 113 | 5x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE, title = table_title) |
| 114 |
) |
|
| 115 |
) |
|
| 116 | ||
| 117 | 5x |
layout_list <- list() |
| 118 | 5x |
layout_list <- add_expr( |
| 119 | 5x |
layout_list, |
| 120 | 5x |
parsed_basic_table_args |
| 121 |
) |
|
| 122 | ||
| 123 | 5x |
split_cols_call <- lapply(arm_var, function(x) {
|
| 124 | 5x |
if (drop_arm_levels) {
|
| 125 | 4x |
substitute( |
| 126 | 4x |
expr = rtables::split_cols_by(x, split_fun = drop_split_levels), |
| 127 | 4x |
env = list(x = x) |
| 128 |
) |
|
| 129 |
} else {
|
|
| 130 | 1x |
substitute( |
| 131 | 1x |
expr = rtables::split_cols_by(x), |
| 132 | 1x |
env = list(x = x) |
| 133 |
) |
|
| 134 |
} |
|
| 135 |
}) |
|
| 136 | 5x |
layout_list <- Reduce(add_expr, split_cols_call, init = layout_list) |
| 137 | ||
| 138 | 5x |
if (add_total && !parallel_vars) {
|
| 139 | 3x |
layout_list <- add_expr( |
| 140 | 3x |
layout_list, |
| 141 | 3x |
substitute( |
| 142 | 3x |
expr = rtables::add_overall_col(total_label), |
| 143 | 3x |
env = list(total_label = total_label) |
| 144 |
) |
|
| 145 |
) |
|
| 146 |
} |
|
| 147 | ||
| 148 | 5x |
env_vars <- list( |
| 149 | 5x |
sum_vars = sum_vars, |
| 150 | 5x |
sum_var_labels = var_labels[sum_vars], |
| 151 | 5x |
na.rm = na.rm, |
| 152 | 5x |
na_level = na_level, |
| 153 | 5x |
denom = ifelse(denominator == "n", "n", "N_col"), |
| 154 | 5x |
stats = c( |
| 155 | 5x |
numeric_stats, |
| 156 | 5x |
ifelse(denominator == "omit", "count", "count_fraction") |
| 157 |
) |
|
| 158 |
) |
|
| 159 | ||
| 160 | 5x |
for (by_var in by_vars) {
|
| 161 | 6x |
split_label <- substitute( |
| 162 | 6x |
expr = teal.data::col_labels(dataname, fill = FALSE)[[by_var]], |
| 163 | 6x |
env = list( |
| 164 | 6x |
dataname = as.name(dataname), |
| 165 | 6x |
by_var = by_var |
| 166 |
) |
|
| 167 |
) |
|
| 168 | ||
| 169 | 6x |
layout_list <- add_expr( |
| 170 | 6x |
layout_list, |
| 171 | 6x |
substitute( |
| 172 | 6x |
rtables::split_rows_by( |
| 173 | 6x |
by_var, |
| 174 | 6x |
split_label = split_label, |
| 175 | 6x |
split_fun = split_fun, |
| 176 | 6x |
label_pos = "topleft" |
| 177 |
), |
|
| 178 | 6x |
env = list( |
| 179 | 6x |
by_var = by_var, |
| 180 | 6x |
split_label = split_label |
| 181 |
) |
|
| 182 |
) |
|
| 183 |
) |
|
| 184 | ||
| 185 | 6x |
if (row_groups) {
|
| 186 | 2x |
layout_list <- add_expr( |
| 187 | 2x |
layout_list, |
| 188 | 2x |
substitute( |
| 189 | 2x |
expr = rtables::summarize_row_groups(var = id_var, cfun = cfun_unique, na_str = na_str), |
| 190 | 2x |
env = list( |
| 191 | 2x |
id_var = id_var, |
| 192 | 2x |
na_str = na_level |
| 193 |
) |
|
| 194 |
) |
|
| 195 |
) |
|
| 196 |
} |
|
| 197 |
} |
|
| 198 | ||
| 199 | 5x |
if (parallel_vars) {
|
| 200 | 1x |
layout_list <- add_expr( |
| 201 | 1x |
layout_list, |
| 202 | 1x |
if (length(var_labels) > 0) {
|
| 203 | ! |
substitute( |
| 204 | ! |
expr = split_cols_by_multivar(vars = sum_vars, varlabels = sum_var_labels), |
| 205 | ! |
env = list(sum_vars = sum_vars, sum_var_labels = var_labels[sum_vars]) |
| 206 |
) |
|
| 207 |
} else {
|
|
| 208 | 1x |
substitute( |
| 209 | 1x |
expr = split_cols_by_multivar(vars = sum_vars), |
| 210 | 1x |
env = list(sum_vars = sum_vars) |
| 211 |
) |
|
| 212 |
} |
|
| 213 |
) |
|
| 214 |
} |
|
| 215 | ||
| 216 | 5x |
if (row_groups) {
|
| 217 | 1x |
layout_list <- layout_list |
| 218 |
} else {
|
|
| 219 | 4x |
layout_list <- add_expr( |
| 220 | 4x |
layout_list, |
| 221 | 4x |
if (parallel_vars) {
|
| 222 | 1x |
if (length(var_labels) > 0) {
|
| 223 | ! |
substitute( |
| 224 | ! |
expr = summarize_colvars( |
| 225 | ! |
na.rm = na.rm, |
| 226 | ! |
denom = denom, |
| 227 | ! |
.stats = stats, |
| 228 | ! |
na_str = na_level |
| 229 |
), |
|
| 230 | ! |
env = env_vars |
| 231 |
) |
|
| 232 |
} else {
|
|
| 233 | 1x |
substitute( |
| 234 | 1x |
expr = summarize_colvars( |
| 235 | 1x |
vars = sum_vars, |
| 236 | 1x |
na.rm = na.rm, |
| 237 | 1x |
denom = denom, |
| 238 | 1x |
.stats = stats, |
| 239 | 1x |
na_str = na_level |
| 240 |
), |
|
| 241 | 1x |
env = env_vars |
| 242 |
) |
|
| 243 |
} |
|
| 244 |
} else {
|
|
| 245 | 3x |
if (length(var_labels > 0)) {
|
| 246 | ! |
substitute( |
| 247 | ! |
expr = analyze_vars( |
| 248 | ! |
vars = sum_vars, |
| 249 | ! |
var_labels = sum_var_labels, |
| 250 | ! |
na.rm = na.rm, |
| 251 | ! |
na_str = na_level, |
| 252 | ! |
denom = denom, |
| 253 | ! |
.stats = stats |
| 254 |
), |
|
| 255 | ! |
env = env_vars |
| 256 |
) |
|
| 257 |
} else {
|
|
| 258 | 3x |
substitute( |
| 259 | 3x |
expr = analyze_vars( |
| 260 | 3x |
vars = sum_vars, |
| 261 | 3x |
na.rm = na.rm, |
| 262 | 3x |
na_str = na_level, |
| 263 | 3x |
denom = denom, |
| 264 | 3x |
.stats = stats |
| 265 |
), |
|
| 266 | 3x |
env = env_vars |
| 267 |
) |
|
| 268 |
} |
|
| 269 |
} |
|
| 270 |
) |
|
| 271 |
} |
|
| 272 | ||
| 273 | 5x |
y$layout <- substitute( |
| 274 | 5x |
expr = lyt <- layout_pipe, |
| 275 | 5x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 276 |
) |
|
| 277 | ||
| 278 | 5x |
if (drop_zero_levels) {
|
| 279 | 1x |
y$table <- substitute( |
| 280 | 1x |
expr = {
|
| 281 | ! |
all_zero <- function(tr) {
|
| 282 | ! |
if (!inherits(tr, "TableRow") || inherits(tr, "LabelRow")) {
|
| 283 | ! |
return(FALSE) |
| 284 |
} |
|
| 285 | ! |
rvs <- unlist(unname(row_values(tr))) |
| 286 | ! |
isTRUE(all(rvs == 0)) |
| 287 |
} |
|
| 288 | ! |
result <- rtables::build_table( |
| 289 | ! |
lyt = lyt, |
| 290 | ! |
df = anl, |
| 291 | ! |
alt_counts_df = parent |
| 292 | ! |
) %>% rtables::trim_rows(criteria = all_zero) |
| 293 | ! |
result |
| 294 |
}, |
|
| 295 | 1x |
env = list(parent = as.name(parentname)) |
| 296 |
) |
|
| 297 |
} else {
|
|
| 298 | 4x |
y$table <- substitute( |
| 299 | 4x |
expr = {
|
| 300 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 301 | ! |
result |
| 302 |
}, |
|
| 303 | 4x |
env = list(parent = as.name(parentname)) |
| 304 |
) |
|
| 305 |
} |
|
| 306 | ||
| 307 | 5x |
y |
| 308 |
} |
|
| 309 | ||
| 310 |
#' teal Module: Summarize Variables by Row Groups |
|
| 311 |
#' |
|
| 312 |
#' This module produces a table to summarize variables by row groups. |
|
| 313 |
#' |
|
| 314 |
#' @inheritParams module_arguments |
|
| 315 |
#' @inheritParams template_summary_by |
|
| 316 |
#' @param arm_var ([teal.transform::choices_selected()])\cr object with all |
|
| 317 |
#' available choices and preselected option for variable names that can be used as `arm_var`. |
|
| 318 |
#' It defines the grouping variable(s) in the results table. |
|
| 319 |
#' If there are two elements selected for `arm_var`, |
|
| 320 |
#' second variable will be nested under the first variable. |
|
| 321 |
#' |
|
| 322 |
#' @inherit module_arguments return seealso |
|
| 323 |
#' |
|
| 324 |
#' @examples |
|
| 325 |
#' ADSL <- tmc_ex_adsl |
|
| 326 |
#' ADLB <- tmc_ex_adlb |
|
| 327 |
#' |
|
| 328 |
#' app <- init( |
|
| 329 |
#' data = cdisc_data( |
|
| 330 |
#' ADSL = ADSL, |
|
| 331 |
#' ADLB = ADLB, |
|
| 332 |
#' code = " |
|
| 333 |
#' ADSL <- tmc_ex_adsl |
|
| 334 |
#' ADLB <- tmc_ex_adlb |
|
| 335 |
#' " |
|
| 336 |
#' ), |
|
| 337 |
#' modules = modules( |
|
| 338 |
#' tm_t_summary_by( |
|
| 339 |
#' label = "Summary by Row Groups Table", |
|
| 340 |
#' dataname = "ADLB", |
|
| 341 |
#' arm_var = choices_selected( |
|
| 342 |
#' choices = variable_choices(ADSL, c("ARM", "ARMCD")),
|
|
| 343 |
#' selected = "ARM" |
|
| 344 |
#' ), |
|
| 345 |
#' add_total = TRUE, |
|
| 346 |
#' by_vars = choices_selected( |
|
| 347 |
#' choices = variable_choices(ADLB, c("PARAM", "AVISIT")),
|
|
| 348 |
#' selected = c("AVISIT")
|
|
| 349 |
#' ), |
|
| 350 |
#' summarize_vars = choices_selected( |
|
| 351 |
#' choices = variable_choices(ADLB, c("AVAL", "CHG")),
|
|
| 352 |
#' selected = c("AVAL")
|
|
| 353 |
#' ), |
|
| 354 |
#' useNA = "ifany", |
|
| 355 |
#' paramcd = choices_selected( |
|
| 356 |
#' choices = value_choices(ADLB, "PARAMCD", "PARAM"), |
|
| 357 |
#' selected = "ALT" |
|
| 358 |
#' ) |
|
| 359 |
#' ) |
|
| 360 |
#' ) |
|
| 361 |
#' ) |
|
| 362 |
#' if (interactive()) {
|
|
| 363 |
#' shinyApp(app$ui, app$server) |
|
| 364 |
#' } |
|
| 365 |
#' |
|
| 366 |
#' @export |
|
| 367 |
tm_t_summary_by <- function(label, |
|
| 368 |
dataname, |
|
| 369 |
parentname = ifelse( |
|
| 370 |
inherits(arm_var, "data_extract_spec"), |
|
| 371 |
teal.transform::datanames_input(arm_var), |
|
| 372 |
"ADSL" |
|
| 373 |
), |
|
| 374 |
arm_var, |
|
| 375 |
by_vars, |
|
| 376 |
summarize_vars, |
|
| 377 |
id_var = teal.transform::choices_selected( |
|
| 378 |
teal.transform::variable_choices(dataname, subset = "USUBJID"), |
|
| 379 |
selected = "USUBJID", fixed = TRUE |
|
| 380 |
), |
|
| 381 |
paramcd = NULL, |
|
| 382 |
add_total = TRUE, |
|
| 383 |
total_label = default_total_label(), |
|
| 384 |
parallel_vars = FALSE, |
|
| 385 |
row_groups = FALSE, |
|
| 386 |
useNA = c("ifany", "no"), # nolint: object_name.
|
|
| 387 |
na_level = default_na_str(), |
|
| 388 |
numeric_stats = c("n", "mean_sd", "median", "range"),
|
|
| 389 |
denominator = teal.transform::choices_selected(c("n", "N", "omit"), "omit", fixed = TRUE),
|
|
| 390 |
drop_arm_levels = TRUE, |
|
| 391 |
drop_zero_levels = TRUE, |
|
| 392 |
pre_output = NULL, |
|
| 393 |
post_output = NULL, |
|
| 394 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 395 | ! |
message("Initializing tm_t_summary_by")
|
| 396 | ! |
checkmate::assert_string(label) |
| 397 | ! |
checkmate::assert_string(dataname) |
| 398 | ! |
checkmate::assert_string(parentname) |
| 399 | ! |
useNA <- match.arg(useNA) # nolint: object_name. |
| 400 | ! |
checkmate::assert_string(na_level) |
| 401 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 402 | ! |
checkmate::assert_class(by_vars, "choices_selected") |
| 403 | ! |
checkmate::assert_class(summarize_vars, "choices_selected") |
| 404 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 405 | ! |
checkmate::assert_class(paramcd, "choices_selected", null.ok = TRUE) |
| 406 | ! |
checkmate::assert_class(denominator, "choices_selected") |
| 407 | ! |
checkmate::assert_flag(add_total) |
| 408 | ! |
checkmate::assert_string(total_label) |
| 409 | ! |
checkmate::assert_flag(drop_zero_levels) |
| 410 | ! |
checkmate::assert_subset(denominator$choices, choices = c("n", "N", "omit"))
|
| 411 | ! |
checkmate::assert_flag(parallel_vars) |
| 412 | ! |
checkmate::assert_flag(row_groups) |
| 413 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 414 | ! |
checkmate::assert_character(numeric_stats, min.len = 1) |
| 415 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 416 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 417 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 418 | ||
| 419 | ! |
numeric_stats_choices <- c("n", "mean_sd", "mean_ci", "geom_mean", "median", "median_ci", "quantiles", "range")
|
| 420 | ! |
numeric_stats <- match.arg(numeric_stats, numeric_stats_choices, several.ok = TRUE) |
| 421 | ||
| 422 | ! |
args <- c(as.list(environment())) |
| 423 | ||
| 424 | ! |
data_extract_list <- list( |
| 425 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 426 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 427 | ! |
paramcd = `if`( |
| 428 | ! |
is.null(paramcd), |
| 429 | ! |
NULL, |
| 430 | ! |
cs_to_des_filter(paramcd, dataname = dataname, multiple = TRUE) |
| 431 |
), |
|
| 432 | ! |
by_vars = cs_to_des_select(by_vars, dataname = dataname, multiple = TRUE, ordered = TRUE), |
| 433 | ! |
summarize_vars = cs_to_des_select(summarize_vars, dataname = dataname, multiple = TRUE, ordered = TRUE) |
| 434 |
) |
|
| 435 | ||
| 436 | ! |
module( |
| 437 | ! |
label = label, |
| 438 | ! |
ui = ui_summary_by, |
| 439 | ! |
ui_args = c(data_extract_list, args), |
| 440 | ! |
server = srv_summary_by, |
| 441 | ! |
server_args = c( |
| 442 | ! |
data_extract_list, |
| 443 | ! |
list( |
| 444 | ! |
dataname = dataname, |
| 445 | ! |
parentname = parentname, |
| 446 | ! |
label = label, |
| 447 | ! |
total_label = total_label, |
| 448 | ! |
na_level = na_level, |
| 449 | ! |
basic_table_args = basic_table_args |
| 450 |
) |
|
| 451 |
), |
|
| 452 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 453 |
) |
|
| 454 |
} |
|
| 455 | ||
| 456 |
#' @keywords internal |
|
| 457 |
ui_summary_by <- function(id, ...) {
|
|
| 458 | ! |
ns <- NS(id) |
| 459 | ! |
a <- list(...) |
| 460 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 461 | ! |
a$arm_var, |
| 462 | ! |
a$id_var, |
| 463 | ! |
a$paramcd, |
| 464 | ! |
a$by_vars, |
| 465 | ! |
a$summarize_vars |
| 466 |
) |
|
| 467 | ||
| 468 | ! |
teal.widgets::standard_layout( |
| 469 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 470 | ! |
encoding = tags$div( |
| 471 |
### Reporter |
|
| 472 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 473 |
### |
|
| 474 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 475 | ! |
teal.transform::datanames_input(a[c("arm_var", "id_var", "paramcd", "by_vars", "summarize_vars")]),
|
| 476 | ! |
teal.transform::data_extract_ui( |
| 477 | ! |
id = ns("arm_var"),
|
| 478 | ! |
label = "Select Treatment Variable", |
| 479 | ! |
data_extract_spec = a$arm_var, |
| 480 | ! |
is_single_dataset = is_single_dataset_value |
| 481 |
), |
|
| 482 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total),
|
| 483 | ! |
`if`( |
| 484 | ! |
is.null(a$paramcd), |
| 485 | ! |
NULL, |
| 486 | ! |
teal.transform::data_extract_ui( |
| 487 | ! |
id = ns("paramcd"),
|
| 488 | ! |
label = "Select Endpoint", |
| 489 | ! |
data_extract_spec = a$paramcd, |
| 490 | ! |
is_single_dataset = is_single_dataset_value |
| 491 |
) |
|
| 492 |
), |
|
| 493 | ! |
teal.transform::data_extract_ui( |
| 494 | ! |
id = ns("by_vars"),
|
| 495 | ! |
label = "Row By Variable", |
| 496 | ! |
data_extract_spec = a$by_vars, |
| 497 | ! |
is_single_dataset = is_single_dataset_value |
| 498 |
), |
|
| 499 | ! |
teal.transform::data_extract_ui( |
| 500 | ! |
id = ns("summarize_vars"),
|
| 501 | ! |
label = "Summarize Variables", |
| 502 | ! |
data_extract_spec = a$summarize_vars, |
| 503 | ! |
is_single_dataset = is_single_dataset_value |
| 504 |
), |
|
| 505 | ! |
checkboxInput(ns("parallel_vars"), "Show summarize variables in parallel", value = a$parallel_vars),
|
| 506 | ! |
checkboxInput(ns("row_groups"), "Summarize number of subjects in row groups", value = a$row_groups),
|
| 507 | ! |
teal.widgets::panel_group( |
| 508 | ! |
teal.widgets::panel_item( |
| 509 | ! |
"Additional table settings", |
| 510 | ! |
checkboxInput(ns("drop_zero_levels"), "Drop rows with 0 count", value = a$drop_zero_levels),
|
| 511 | ! |
radioButtons( |
| 512 | ! |
ns("useNA"),
|
| 513 | ! |
label = "Display NA counts", |
| 514 | ! |
choices = c("ifany", "no"),
|
| 515 | ! |
selected = a$useNA |
| 516 |
), |
|
| 517 | ! |
teal.widgets::optionalSelectInput( |
| 518 | ! |
inputId = ns("denominator"),
|
| 519 | ! |
label = "Denominator choice", |
| 520 | ! |
choices = a$denominator$choices, |
| 521 | ! |
selected = a$denominator$selected, |
| 522 | ! |
fixed = a$denominator$fixed |
| 523 |
), |
|
| 524 | ! |
checkboxGroupInput( |
| 525 | ! |
ns("numeric_stats"),
|
| 526 | ! |
label = "Choose the statistics to display for numeric variables", |
| 527 | ! |
choices = c( |
| 528 | ! |
"n" = "n", |
| 529 | ! |
"Mean (SD)" = "mean_sd", |
| 530 | ! |
"Mean 95% CI" = "mean_ci", |
| 531 | ! |
"Geometric Mean" = "geom_mean", |
| 532 | ! |
"Median" = "median", |
| 533 | ! |
"Median 95% CI" = "median_ci", |
| 534 | ! |
"25% and 75%-ile" = "quantiles", |
| 535 | ! |
"Min - Max" = "range" |
| 536 |
), |
|
| 537 | ! |
selected = a$numeric_stats |
| 538 |
), |
|
| 539 | ! |
if (a$dataname == a$parentname) {
|
| 540 | ! |
shinyjs::hidden( |
| 541 | ! |
checkboxInput( |
| 542 | ! |
ns("drop_arm_levels"),
|
| 543 | ! |
label = "it's a BUG if you see this", |
| 544 | ! |
value = TRUE |
| 545 |
) |
|
| 546 |
) |
|
| 547 |
} else {
|
|
| 548 | ! |
checkboxInput( |
| 549 | ! |
ns("drop_arm_levels"),
|
| 550 | ! |
label = sprintf("Drop columns not in filtered %s", a$dataname),
|
| 551 | ! |
value = a$drop_arm_levels |
| 552 |
) |
|
| 553 |
} |
|
| 554 |
) |
|
| 555 |
), |
|
| 556 | ! |
teal.widgets::panel_group( |
| 557 | ! |
teal.widgets::panel_item( |
| 558 | ! |
"Additional Variables Info", |
| 559 | ! |
teal.transform::data_extract_ui( |
| 560 | ! |
id = ns("id_var"),
|
| 561 | ! |
label = "Subject Identifier", |
| 562 | ! |
data_extract_spec = a$id_var, |
| 563 | ! |
is_single_dataset = is_single_dataset_value |
| 564 |
) |
|
| 565 |
) |
|
| 566 |
) |
|
| 567 |
), |
|
| 568 | ! |
forms = tagList( |
| 569 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 570 |
), |
|
| 571 | ! |
pre_output = a$pre_output, |
| 572 | ! |
post_output = a$post_output |
| 573 |
) |
|
| 574 |
} |
|
| 575 | ||
| 576 |
#' @keywords internal |
|
| 577 |
srv_summary_by <- function(id, |
|
| 578 |
data, |
|
| 579 |
reporter, |
|
| 580 |
filter_panel_api, |
|
| 581 |
dataname, |
|
| 582 |
parentname, |
|
| 583 |
arm_var, |
|
| 584 |
id_var, |
|
| 585 |
paramcd, |
|
| 586 |
by_vars, |
|
| 587 |
summarize_vars, |
|
| 588 |
add_total, |
|
| 589 |
total_label, |
|
| 590 |
na_level, |
|
| 591 |
drop_arm_levels, |
|
| 592 |
drop_zero_levels, |
|
| 593 |
label, |
|
| 594 |
basic_table_args) {
|
|
| 595 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 596 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 597 | ! |
checkmate::assert_class(data, "reactive") |
| 598 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 599 | ||
| 600 | ! |
moduleServer(id, function(input, output, session) {
|
| 601 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 602 | ! |
vars <- list(arm_var = arm_var, id_var = id_var, summarize_vars = summarize_vars, by_vars = by_vars) |
| 603 | ||
| 604 | ! |
if (!is.null(paramcd)) {
|
| 605 | ! |
vars[["paramcd"]] <- paramcd |
| 606 |
} |
|
| 607 | ||
| 608 | ! |
validation_rules <- list( |
| 609 | ! |
arm_var = ~ if (length(.) != 1 && length(.) != 2) {
|
| 610 | ! |
"Please select 1 or 2 column variables" |
| 611 |
}, |
|
| 612 | ! |
id_var = shinyvalidate::sv_required("Please select a subject identifier."),
|
| 613 | ! |
summarize_vars = shinyvalidate::sv_required("Please select a summarize variable.")
|
| 614 |
) |
|
| 615 | ||
| 616 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 617 | ! |
data_extract = vars, |
| 618 | ! |
datasets = data, |
| 619 | ! |
select_validation_rule = validation_rules, |
| 620 | ! |
filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select a filter.")) |
| 621 |
) |
|
| 622 | ||
| 623 | ! |
iv_r <- reactive({
|
| 624 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 625 | ! |
iv$add_rule("numeric_stats", shinyvalidate::sv_required("Please select at least one statistic to display."))
|
| 626 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 627 |
}) |
|
| 628 | ||
| 629 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 630 | ! |
selector_list = selector_list, |
| 631 | ! |
datasets = data, |
| 632 | ! |
merge_function = "dplyr::inner_join" |
| 633 |
) |
|
| 634 | ||
| 635 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 636 | ! |
id = "adsl_merge", |
| 637 | ! |
datasets = data, |
| 638 | ! |
data_extract = list(arm_var = arm_var), |
| 639 | ! |
anl_name = "ANL_ADSL" |
| 640 |
) |
|
| 641 | ||
| 642 | ! |
anl_q <- reactive({
|
| 643 | ! |
data() %>% |
| 644 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 645 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 646 |
}) |
|
| 647 | ||
| 648 | ! |
merged <- list( |
| 649 | ! |
anl_input_r = anl_inputs, |
| 650 | ! |
adsl_input_r = adsl_inputs, |
| 651 | ! |
anl_q = anl_q |
| 652 |
) |
|
| 653 | ||
| 654 |
# Prepare the analysis environment (filter data, check data, populate envir). |
|
| 655 | ! |
validate_checks <- reactive({
|
| 656 | ! |
teal::validate_inputs(iv_r()) |
| 657 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 658 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 659 | ||
| 660 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 661 | ! |
input_id_var <- names(merged$anl_input_r()$columns_source$id_var) |
| 662 | ! |
input_by_vars <- names(merged$anl_input_r()$columns_source$by_vars) |
| 663 | ! |
input_summarize_vars <- names(merged$anl_input_r()$columns_source$summarize_var) |
| 664 | ! |
input_paramcd <- `if`(is.null(paramcd), NULL, unlist(paramcd$filter)["vars_selected"]) |
| 665 | ||
| 666 |
# validate inputs |
|
| 667 | ! |
validate_standard_inputs( |
| 668 | ! |
adsl = adsl_filtered, |
| 669 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 670 | ! |
anl = anl_filtered, |
| 671 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_by_vars, input_summarize_vars, input_id_var),
|
| 672 | ! |
arm_var = input_arm_var[[1]] |
| 673 |
) |
|
| 674 | ||
| 675 | ! |
if (input$parallel_vars) {
|
| 676 | ! |
validate(shiny::need( |
| 677 | ! |
all(vapply(anl_filtered[input_summarize_vars], is.numeric, logical(1))), |
| 678 | ! |
"Summarize variables must all be numeric to display in parallel columns." |
| 679 |
)) |
|
| 680 |
} |
|
| 681 |
}) |
|
| 682 | ||
| 683 |
# The R-code corresponding to the analysis. |
|
| 684 | ! |
all_q <- reactive({
|
| 685 | ! |
validate_checks() |
| 686 | ! |
summarize_vars <- as.vector(merged$anl_input_r()$columns_source$summarize_vars) |
| 687 | ! |
var_labels <- teal.data::col_labels(merged$anl_q()[[dataname]][, summarize_vars, drop = FALSE]) |
| 688 | ||
| 689 | ! |
my_calls <- template_summary_by( |
| 690 | ! |
parentname = "ANL_ADSL", |
| 691 | ! |
dataname = "ANL", |
| 692 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 693 | ! |
sum_vars = summarize_vars, |
| 694 | ! |
by_vars = as.vector(merged$anl_input_r()$columns_source$by_vars), |
| 695 | ! |
var_labels = var_labels, |
| 696 | ! |
id_var = as.vector(merged$anl_input_r()$columns_source$id_var), |
| 697 | ! |
na.rm = ifelse(input$useNA == "ifany", FALSE, TRUE), |
| 698 | ! |
na_level = na_level, |
| 699 | ! |
numeric_stats = input$numeric_stats, |
| 700 | ! |
denominator = input$denominator, |
| 701 | ! |
add_total = input$add_total, |
| 702 | ! |
total_label = total_label, |
| 703 | ! |
parallel_vars = input$parallel_vars, |
| 704 | ! |
row_groups = input$row_groups, |
| 705 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 706 | ! |
drop_zero_levels = input$drop_zero_levels, |
| 707 | ! |
basic_table_args = basic_table_args |
| 708 |
) |
|
| 709 | ||
| 710 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 711 |
}) |
|
| 712 | ||
| 713 |
# Outputs to render. |
|
| 714 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 715 | ||
| 716 | ! |
teal.widgets::table_with_settings_srv( |
| 717 | ! |
id = "table", |
| 718 | ! |
table_r = table_r |
| 719 |
) |
|
| 720 | ||
| 721 |
# Render R code. |
|
| 722 | ! |
teal.widgets::verbatim_popup_srv( |
| 723 | ! |
id = "rcode", |
| 724 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 725 | ! |
title = label |
| 726 |
) |
|
| 727 | ||
| 728 |
### REPORTER |
|
| 729 | ! |
if (with_reporter) {
|
| 730 | ! |
card_fun <- function(comment, label) {
|
| 731 | ! |
card <- teal::report_card_template( |
| 732 | ! |
title = "Summarize Variables by Row Groups Table", |
| 733 | ! |
label = label, |
| 734 | ! |
with_filter = with_filter, |
| 735 | ! |
filter_panel_api = filter_panel_api |
| 736 |
) |
|
| 737 | ! |
card$append_text("Table", "header3")
|
| 738 | ! |
card$append_table(table_r()) |
| 739 | ! |
if (!comment == "") {
|
| 740 | ! |
card$append_text("Comment", "header3")
|
| 741 | ! |
card$append_text(comment) |
| 742 |
} |
|
| 743 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 744 | ! |
card |
| 745 |
} |
|
| 746 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 747 |
} |
|
| 748 |
### |
|
| 749 |
}) |
|
| 750 |
} |
| 1 |
#' Template: Binary Outcome |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a binary outcome analysis. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param responder_val (`character`)\cr the short label for observations to |
|
| 7 |
#' translate `AVALC` into responder/non-responder. |
|
| 8 |
#' @param responder_val_levels (`character`)\cr the levels of responses that will be shown in the multinomial |
|
| 9 |
#' response estimations. |
|
| 10 |
#' @param show_rsp_cat (`logical`)\cr display the multinomial response estimations. |
|
| 11 |
#' @param paramcd (`character`)\cr response parameter value to use in the table title. |
|
| 12 |
#' |
|
| 13 |
#' @inherit template_arguments return |
|
| 14 |
#' |
|
| 15 |
#' @seealso [tm_t_binary_outcome()] |
|
| 16 |
#' |
|
| 17 |
#' @keywords internal |
|
| 18 |
template_binary_outcome <- function(dataname, |
|
| 19 |
parentname, |
|
| 20 |
arm_var, |
|
| 21 |
paramcd, |
|
| 22 |
ref_arm = NULL, |
|
| 23 |
comp_arm = NULL, |
|
| 24 |
compare_arm = FALSE, |
|
| 25 |
combine_comp_arms = FALSE, |
|
| 26 |
aval_var = "AVALC", |
|
| 27 |
show_rsp_cat = TRUE, |
|
| 28 |
responder_val = c("Complete Response (CR)", "Partial Response (PR)"),
|
|
| 29 |
responder_val_levels = responder_val, |
|
| 30 |
control = list( |
|
| 31 |
global = list(method = "waldcc", conf_level = 0.95), |
|
| 32 |
unstrat = list(method_ci = "waldcc", method_test = "schouten", odds = TRUE), |
|
| 33 |
strat = list(method_ci = "cmh", method_test = "cmh", strat = NULL) |
|
| 34 |
), |
|
| 35 |
add_total = FALSE, |
|
| 36 |
total_label = default_total_label(), |
|
| 37 |
na_level = default_na_str(), |
|
| 38 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 39 | 7x |
checkmate::assert_string(dataname) |
| 40 | 7x |
checkmate::assert_string(parentname) |
| 41 | 7x |
checkmate::assert_string(arm_var) |
| 42 | 7x |
checkmate::assert_string(aval_var) |
| 43 | 7x |
checkmate::assert_flag(compare_arm) |
| 44 | 7x |
checkmate::assert_flag(combine_comp_arms) |
| 45 | 7x |
checkmate::assert_flag(show_rsp_cat) |
| 46 | 7x |
checkmate::assert_flag(add_total) |
| 47 | 7x |
checkmate::assert_string(na_level) |
| 48 | 7x |
checkmate::assert_string(total_label) |
| 49 | ||
| 50 | 7x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 51 | 7x |
y <- list() |
| 52 | ||
| 53 | 7x |
data_list <- list() |
| 54 | ||
| 55 | 7x |
data_list <- add_expr( |
| 56 | 7x |
data_list, |
| 57 | 7x |
prepare_arm( |
| 58 | 7x |
dataname = dataname, |
| 59 | 7x |
arm_var = arm_var, |
| 60 | 7x |
ref_arm = ref_arm, |
| 61 | 7x |
comp_arm = comp_arm, |
| 62 | 7x |
ref_arm_val = ref_arm_val, |
| 63 | 7x |
compare_arm = compare_arm |
| 64 |
) |
|
| 65 |
) |
|
| 66 | ||
| 67 | 7x |
data_list <- add_expr( |
| 68 | 7x |
data_list, |
| 69 | 7x |
substitute_names( |
| 70 | 7x |
expr = dplyr::mutate(is_rsp = aval_var %in% responder_val) %>% |
| 71 | 7x |
dplyr::mutate(aval = factor(aval_var, levels = responder_val_levels)), |
| 72 | 7x |
names = list( |
| 73 | 7x |
aval = as.name(aval_var) |
| 74 |
), |
|
| 75 | 7x |
others = list( |
| 76 | 7x |
responder_val = responder_val, |
| 77 | 7x |
responder_val_levels = responder_val_levels, |
| 78 | 7x |
aval_var = as.name(aval_var) |
| 79 |
) |
|
| 80 |
) |
|
| 81 |
) |
|
| 82 | ||
| 83 | 7x |
y$data <- substitute( |
| 84 | 7x |
expr = {
|
| 85 | ! |
anl <- data_pipe |
| 86 | ! |
parentname <- arm_preparation %>% df_explicit_na(na_level = na_str) |
| 87 |
}, |
|
| 88 | 7x |
env = list( |
| 89 | 7x |
data_pipe = pipe_expr(data_list), |
| 90 | 7x |
parentname = as.name(parentname), |
| 91 | 7x |
arm_preparation = prepare_arm( |
| 92 | 7x |
dataname = parentname, |
| 93 | 7x |
arm_var = arm_var, |
| 94 | 7x |
ref_arm = ref_arm, |
| 95 | 7x |
comp_arm = comp_arm, |
| 96 | 7x |
ref_arm_val = ref_arm_val, |
| 97 | 7x |
compare_arm = compare_arm |
| 98 |
), |
|
| 99 | 7x |
na_str = na_level |
| 100 |
) |
|
| 101 |
) |
|
| 102 | ||
| 103 | 7x |
if (compare_arm && combine_comp_arms) {
|
| 104 | 1x |
y$combine_comp_arms <- substitute( |
| 105 | 1x |
expr = groups <- combine_groups(fct = df[[group]], ref = ref_arm_val), |
| 106 | 1x |
env = list( |
| 107 | 1x |
df = as.name(parentname), |
| 108 | 1x |
group = arm_var, |
| 109 | 1x |
ref_arm_val = ref_arm_val |
| 110 |
) |
|
| 111 |
) |
|
| 112 |
} |
|
| 113 | ||
| 114 | 7x |
table_title <- if (length(responder_val) > 1) {
|
| 115 | 7x |
paste( |
| 116 | 7x |
"Table of", paramcd, "for", paste(utils::head(responder_val, -1), collapse = ", "), |
| 117 | 7x |
"and", utils::tail(responder_val, 1), "Responders" |
| 118 |
) |
|
| 119 |
} else {
|
|
| 120 | ! |
paste("Table of", paramcd, "for", responder_val, "Responders")
|
| 121 |
} |
|
| 122 | ||
| 123 | 7x |
strata_var <- control$strat$strat |
| 124 | 7x |
subtitle <- ifelse(length(strata_var) == 0, "", paste("Stratified by", paste(strata_var, collapse = " and ")))
|
| 125 | ||
| 126 | 7x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 127 | 7x |
teal.widgets::resolve_basic_table_args( |
| 128 | 7x |
user_table = basic_table_args, |
| 129 | 7x |
module_table = teal.widgets::basic_table_args( |
| 130 | 7x |
show_colcounts = TRUE, |
| 131 | 7x |
title = table_title, |
| 132 | 7x |
subtitles = subtitle |
| 133 |
) |
|
| 134 |
) |
|
| 135 |
) |
|
| 136 | ||
| 137 | 7x |
layout_list <- list() |
| 138 | 7x |
layout_list <- add_expr( |
| 139 | 7x |
layout_list, |
| 140 | 7x |
parsed_basic_table_args |
| 141 |
) |
|
| 142 | ||
| 143 | 7x |
if (!compare_arm && !combine_comp_arms && add_total) {
|
| 144 | ! |
layout_list <- add_expr( |
| 145 | ! |
layout_list, |
| 146 | ! |
substitute( |
| 147 | ! |
rtables::split_cols_by( |
| 148 | ! |
var = arm_var, |
| 149 | ! |
split_fun = add_overall_level(total_label, first = FALSE) |
| 150 |
), |
|
| 151 | ! |
env = list( |
| 152 | ! |
arm_var = arm_var, |
| 153 | ! |
total_label = total_label |
| 154 |
) |
|
| 155 |
) |
|
| 156 |
) |
|
| 157 |
} else {
|
|
| 158 | 7x |
layout_list <- add_expr( |
| 159 | 7x |
layout_list, |
| 160 | 7x |
split_col_expr( |
| 161 | 7x |
compare = compare_arm, |
| 162 | 7x |
combine = combine_comp_arms, |
| 163 | 7x |
arm_var = arm_var, |
| 164 | 7x |
ref = ref_arm_val |
| 165 |
) |
|
| 166 |
) |
|
| 167 |
} |
|
| 168 | ||
| 169 | 7x |
layout_list <- add_expr( |
| 170 | 7x |
layout_list, |
| 171 | 7x |
substitute( |
| 172 | 7x |
estimate_proportion( |
| 173 | 7x |
vars = "is_rsp", |
| 174 | 7x |
conf_level = conf_level, |
| 175 | 7x |
method = method, |
| 176 | 7x |
table_names = "prop_est" |
| 177 |
), |
|
| 178 | 7x |
env = list( |
| 179 | 7x |
conf_level = control$global$conf_level, |
| 180 | 7x |
method = control$global$method |
| 181 |
) |
|
| 182 |
) |
|
| 183 |
) |
|
| 184 | ||
| 185 | 7x |
if (compare_arm) {
|
| 186 | 5x |
layout_list <- add_expr( |
| 187 | 5x |
layout_list, |
| 188 | 5x |
substitute( |
| 189 | 5x |
expr = estimate_proportion_diff( |
| 190 | 5x |
vars = "is_rsp", show_labels = "visible", |
| 191 | 5x |
var_labels = "Unstratified Analysis", |
| 192 | 5x |
conf_level = conf_level, |
| 193 | 5x |
method = method_ci, |
| 194 | 5x |
table_names = "u_prop_diff" |
| 195 |
) %>% |
|
| 196 | 5x |
test_proportion_diff( |
| 197 | 5x |
vars = "is_rsp", |
| 198 | 5x |
method = method_test, |
| 199 | 5x |
table_names = "u_test_diff" |
| 200 |
), |
|
| 201 | 5x |
env = list( |
| 202 | 5x |
conf_level = control$global$conf_level, |
| 203 | 5x |
method_ci = control$unstrat$method_ci, |
| 204 | 5x |
method_test = control$unstrat$method_test |
| 205 |
) |
|
| 206 |
) |
|
| 207 |
) |
|
| 208 | ||
| 209 | 5x |
if (control$unstrat$odds) {
|
| 210 | 5x |
layout_list <- add_expr( |
| 211 | 5x |
layout_list, |
| 212 | 5x |
substitute( |
| 213 | 5x |
expr = estimate_odds_ratio( |
| 214 | 5x |
vars = "is_rsp", |
| 215 | 5x |
conf_level = conf_level, |
| 216 | 5x |
table_names = "u_est_or" |
| 217 |
), |
|
| 218 | 5x |
env = list(conf_level = control$global$conf_level) |
| 219 |
) |
|
| 220 |
) |
|
| 221 |
} |
|
| 222 | ||
| 223 | 5x |
if (!is.null(control$strat$strat)) {
|
| 224 | 1x |
layout_list <- add_expr( |
| 225 | 1x |
layout_list, |
| 226 | 1x |
substitute( |
| 227 | 1x |
expr = estimate_proportion_diff( |
| 228 | 1x |
vars = "is_rsp", show_labels = "visible", |
| 229 | 1x |
var_labels = "Stratified Analysis", |
| 230 | 1x |
variables = list(strata = strata), |
| 231 | 1x |
conf_level = conf_level, |
| 232 | 1x |
method = method_ci, |
| 233 | 1x |
table_names = "s_prop_diff" |
| 234 |
) %>% |
|
| 235 | 1x |
test_proportion_diff( |
| 236 | 1x |
vars = "is_rsp", |
| 237 | 1x |
method = method_test, |
| 238 | 1x |
variables = list(strata = strata), |
| 239 | 1x |
table_names = "s_test_diff" |
| 240 |
), |
|
| 241 | 1x |
env = list( |
| 242 | 1x |
conf_level = control$global$conf_level, |
| 243 | 1x |
method_ci = control$strat$method_ci, |
| 244 | 1x |
strata = control$strat$strat, |
| 245 | 1x |
method_test = control$strat$method_test, |
| 246 | 1x |
arm_var = arm_var |
| 247 |
) |
|
| 248 |
) |
|
| 249 |
) |
|
| 250 |
} |
|
| 251 |
} |
|
| 252 | ||
| 253 | 7x |
if (compare_arm && !is.null(control$strat$strat)) {
|
| 254 | 1x |
layout_list <- if (combine_comp_arms) {
|
| 255 | ! |
add_expr( |
| 256 | ! |
layout_list, |
| 257 | ! |
substitute( |
| 258 | ! |
expr = estimate_odds_ratio( |
| 259 | ! |
vars = "is_rsp", |
| 260 | ! |
variables = list(arm = arm_var, strata = strata), |
| 261 | ! |
conf_level = conf_level, |
| 262 | ! |
table_names = "s_est_or", |
| 263 | ! |
groups_list = groups |
| 264 |
), |
|
| 265 | ! |
env = list( |
| 266 | ! |
conf_level = control$global$conf_level, |
| 267 | ! |
strata = control$strat$strat, |
| 268 | ! |
arm_var = arm_var |
| 269 |
) |
|
| 270 |
) |
|
| 271 |
) |
|
| 272 |
} else {
|
|
| 273 | 1x |
add_expr( |
| 274 | 1x |
layout_list, |
| 275 | 1x |
substitute( |
| 276 | 1x |
expr = estimate_odds_ratio( |
| 277 | 1x |
vars = "is_rsp", |
| 278 | 1x |
variables = list(arm = arm_var, strata = strata), |
| 279 | 1x |
conf_level = conf_level, |
| 280 | 1x |
table_names = "s_est_or" |
| 281 |
), |
|
| 282 | 1x |
env = list( |
| 283 | 1x |
conf_level = control$global$conf_level, |
| 284 | 1x |
strata = control$strat$strat, |
| 285 | 1x |
arm_var = arm_var |
| 286 |
) |
|
| 287 |
) |
|
| 288 |
) |
|
| 289 |
} |
|
| 290 |
} |
|
| 291 | ||
| 292 | 7x |
if (show_rsp_cat) {
|
| 293 | 5x |
layout_list <- add_expr( |
| 294 | 5x |
layout_list, |
| 295 | 5x |
substitute( |
| 296 | 5x |
estimate_multinomial_response( |
| 297 | 5x |
var = aval_var, |
| 298 | 5x |
conf_level = conf_level, |
| 299 | 5x |
method = method |
| 300 |
), |
|
| 301 | 5x |
list( |
| 302 | 5x |
conf_level = control$global$conf_level, |
| 303 | 5x |
method = control$global$method, |
| 304 | 5x |
aval_var = aval_var |
| 305 |
) |
|
| 306 |
) |
|
| 307 |
) |
|
| 308 |
} |
|
| 309 | ||
| 310 | 7x |
y$layout <- substitute( |
| 311 | 7x |
expr = lyt <- layout_pipe, |
| 312 | 7x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 313 |
) |
|
| 314 | ||
| 315 | 7x |
y$table <- substitute( |
| 316 | 7x |
expr = {
|
| 317 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parentname) |
| 318 | ! |
result |
| 319 |
}, |
|
| 320 | 7x |
env = list(parentname = as.name(parentname)) |
| 321 |
) |
|
| 322 | 7x |
y |
| 323 |
} |
|
| 324 | ||
| 325 |
#' teal Module: Binary Outcome Table |
|
| 326 |
#' |
|
| 327 |
#' This module produces a binary outcome response summary table, with the option to match the template for |
|
| 328 |
#' response table `RSPT01` available in the TLG Catalog [here]( |
|
| 329 |
#' https://insightsengineering.github.io/tlg-catalog/stable/tables/efficacy/rspt01.html). |
|
| 330 |
#' |
|
| 331 |
#' @inheritParams module_arguments |
|
| 332 |
#' @inheritParams template_binary_outcome |
|
| 333 |
#' @param rsp_table (`logical`)\cr whether the initial set-up of the module should match `RSPT01`. Defaults to `FALSE`. |
|
| 334 |
#' @param control (named `list`)\cr named list containing 3 named lists as follows: |
|
| 335 |
#' * `global`: a list of settings for overall analysis with 2 named elements `method` and `conf_level`. |
|
| 336 |
#' * `unstrat`: a list of settings for unstratified analysis with 3 named elements `method_ci` and `method_test`, and |
|
| 337 |
#' `odds`. See [tern::estimate_proportion_diff()], [tern::test_proportion_diff()], and |
|
| 338 |
#' [tern::estimate_odds_ratio()], respectively, for options and details on how these settings are implemented in the |
|
| 339 |
#' analysis. |
|
| 340 |
#' * `strat`: a list of settings for stratified analysis with elements `method_ci` and `method_test`. See |
|
| 341 |
#' [tern::estimate_proportion_diff()] and [tern::test_proportion_diff()], respectively, for options and details on |
|
| 342 |
#' how these settings are implemented in the analysis. |
|
| 343 |
#' |
|
| 344 |
#' @details |
|
| 345 |
#' * The display order of response categories inherits the factor level order of the source data. Use |
|
| 346 |
#' [base::factor()] and its `levels` argument to manipulate the source data in order to include/exclude |
|
| 347 |
#' or re-categorize response categories and arrange the display order. If response categories are `"Missing"`, |
|
| 348 |
#' `"Not Evaluable (NE)"`, or `"Missing or unevaluable"`, 95% confidence interval will not be calculated. |
|
| 349 |
#' |
|
| 350 |
#' * Reference arms are automatically combined if multiple arms selected as reference group. |
|
| 351 |
#' |
|
| 352 |
#' @inherit module_arguments return seealso |
|
| 353 |
#' |
|
| 354 |
#' @examples |
|
| 355 |
#' library(dplyr) |
|
| 356 |
#' |
|
| 357 |
#' ADSL <- tmc_ex_adsl |
|
| 358 |
#' ADRS <- tmc_ex_adrs %>% |
|
| 359 |
#' mutate( |
|
| 360 |
#' AVALC = d_onco_rsp_label(AVALC) %>% |
|
| 361 |
#' with_label("Character Result/Finding")
|
|
| 362 |
#' ) %>% |
|
| 363 |
#' filter(PARAMCD != "OVRINV" | AVISIT == "FOLLOW UP") |
|
| 364 |
#' |
|
| 365 |
#' arm_ref_comp <- list( |
|
| 366 |
#' ARMCD = list(ref = "ARM B", comp = c("ARM A", "ARM C")),
|
|
| 367 |
#' ARM = list(ref = "B: Placebo", comp = c("A: Drug X", "C: Combination"))
|
|
| 368 |
#' ) |
|
| 369 |
#' app <- init( |
|
| 370 |
#' data = cdisc_data( |
|
| 371 |
#' ADSL = ADSL, |
|
| 372 |
#' ADRS = ADRS, |
|
| 373 |
#' code = " |
|
| 374 |
#' ADSL <- tmc_ex_adsl |
|
| 375 |
#' ADRS <- tmc_ex_adrs %>% |
|
| 376 |
#' mutate( |
|
| 377 |
#' AVALC = d_onco_rsp_label(AVALC) %>% |
|
| 378 |
#' with_label(\"Character Result/Finding\") |
|
| 379 |
#' ) %>% |
|
| 380 |
#' filter(PARAMCD != \"OVRINV\" | AVISIT == \"FOLLOW UP\") |
|
| 381 |
#' " |
|
| 382 |
#' ), |
|
| 383 |
#' modules = modules( |
|
| 384 |
#' tm_t_binary_outcome( |
|
| 385 |
#' label = "Responders", |
|
| 386 |
#' dataname = "ADRS", |
|
| 387 |
#' paramcd = choices_selected( |
|
| 388 |
#' choices = value_choices(ADRS, "PARAMCD", "PARAM"), |
|
| 389 |
#' selected = "BESRSPI" |
|
| 390 |
#' ), |
|
| 391 |
#' arm_var = choices_selected( |
|
| 392 |
#' choices = variable_choices(ADRS, c("ARM", "ARMCD", "ACTARMCD")),
|
|
| 393 |
#' selected = "ARM" |
|
| 394 |
#' ), |
|
| 395 |
#' arm_ref_comp = arm_ref_comp, |
|
| 396 |
#' strata_var = choices_selected( |
|
| 397 |
#' choices = variable_choices(ADRS, c("SEX", "BMRKR2", "RACE")),
|
|
| 398 |
#' selected = "RACE" |
|
| 399 |
#' ), |
|
| 400 |
#' default_responses = list( |
|
| 401 |
#' BESRSPI = list( |
|
| 402 |
#' rsp = c("Complete Response (CR)", "Partial Response (PR)"),
|
|
| 403 |
#' levels = c( |
|
| 404 |
#' "Complete Response (CR)", "Partial Response (PR)", |
|
| 405 |
#' "Stable Disease (SD)", "Progressive Disease (PD)" |
|
| 406 |
#' ) |
|
| 407 |
#' ), |
|
| 408 |
#' INVET = list( |
|
| 409 |
#' rsp = c("Stable Disease (SD)", "Not Evaluable (NE)"),
|
|
| 410 |
#' levels = c( |
|
| 411 |
#' "Complete Response (CR)", "Not Evaluable (NE)", "Partial Response (PR)", |
|
| 412 |
#' "Progressive Disease (PD)", "Stable Disease (SD)" |
|
| 413 |
#' ) |
|
| 414 |
#' ), |
|
| 415 |
#' OVRINV = list( |
|
| 416 |
#' rsp = c("Progressive Disease (PD)", "Stable Disease (SD)"),
|
|
| 417 |
#' levels = c("Progressive Disease (PD)", "Stable Disease (SD)", "Not Evaluable (NE)")
|
|
| 418 |
#' ) |
|
| 419 |
#' ) |
|
| 420 |
#' ) |
|
| 421 |
#' ) |
|
| 422 |
#' ) |
|
| 423 |
#' if (interactive()) {
|
|
| 424 |
#' shinyApp(app$ui, app$server) |
|
| 425 |
#' } |
|
| 426 |
#' |
|
| 427 |
#' @export |
|
| 428 |
tm_t_binary_outcome <- function(label, |
|
| 429 |
dataname, |
|
| 430 |
parentname = ifelse( |
|
| 431 |
test = inherits(arm_var, "data_extract_spec"), |
|
| 432 |
yes = teal.transform::datanames_input(arm_var), |
|
| 433 |
no = "ADSL" |
|
| 434 |
), |
|
| 435 |
arm_var, |
|
| 436 |
arm_ref_comp = NULL, |
|
| 437 |
paramcd, |
|
| 438 |
strata_var, |
|
| 439 |
aval_var = teal.transform::choices_selected( |
|
| 440 |
choices = teal.transform::variable_choices(dataname, c("AVALC", "SEX")),
|
|
| 441 |
selected = "AVALC", fixed = FALSE |
|
| 442 |
), |
|
| 443 |
conf_level = teal.transform::choices_selected( |
|
| 444 |
c(0.95, 0.9, 0.8), 0.95, |
|
| 445 |
keep_order = TRUE |
|
| 446 |
), |
|
| 447 |
default_responses = |
|
| 448 |
c("CR", "PR", "Y", "Complete Response (CR)", "Partial Response (PR)", "M"),
|
|
| 449 |
rsp_table = FALSE, |
|
| 450 |
control = list( |
|
| 451 |
global = list( |
|
| 452 |
method = ifelse(rsp_table, "clopper-pearson", "waldcc"), |
|
| 453 |
conf_level = 0.95 |
|
| 454 |
), |
|
| 455 |
unstrat = list( |
|
| 456 |
method_ci = ifelse(rsp_table, "wald", "waldcc"), |
|
| 457 |
method_test = "schouten", |
|
| 458 |
odds = TRUE |
|
| 459 |
), |
|
| 460 |
strat = list(method_ci = "cmh", method_test = "cmh") |
|
| 461 |
), |
|
| 462 |
add_total = FALSE, |
|
| 463 |
total_label = default_total_label(), |
|
| 464 |
na_level = default_na_str(), |
|
| 465 |
pre_output = NULL, |
|
| 466 |
post_output = NULL, |
|
| 467 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 468 | ! |
message("Initializing tm_t_binary_outcome")
|
| 469 | ! |
checkmate::assert_string(label) |
| 470 | ! |
checkmate::assert_string(dataname) |
| 471 | ! |
checkmate::assert_string(parentname) |
| 472 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 473 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 474 | ! |
checkmate::assert_class(strata_var, "choices_selected") |
| 475 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 476 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 477 | ! |
checkmate::assert_flag(add_total) |
| 478 | ! |
checkmate::assert_string(total_label) |
| 479 | ! |
checkmate::assert_string(na_level) |
| 480 | ! |
checkmate::assert( |
| 481 | ! |
checkmate::check_class(default_responses, classes = "list"), |
| 482 | ! |
checkmate::check_class(default_responses, classes = "character"), |
| 483 | ! |
checkmate::check_class(default_responses, classes = "numeric"), |
| 484 | ! |
checkmate::check_class(default_responses, classes = "NULL") |
| 485 |
) |
|
| 486 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 487 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 488 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 489 | ||
| 490 |
# control checks |
|
| 491 | ! |
checkmate::assert_names(names(control), permutation.of = c("global", "unstrat", "strat"))
|
| 492 | ! |
checkmate::assert_names(names(control$global), permutation.of = c("method", "conf_level"))
|
| 493 | ! |
checkmate::assert_names(names(control$unstrat), permutation.of = c("method_ci", "method_test", "odds"))
|
| 494 | ! |
checkmate::assert_names(names(control$strat), permutation.of = c("method_ci", "method_test"))
|
| 495 | ! |
checkmate::assert_subset( |
| 496 | ! |
control$global$method, |
| 497 | ! |
c("wald", "waldcc", "clopper-pearson", "wilson", "wilsonc", "jeffreys", "agresti-coull")
|
| 498 |
) |
|
| 499 | ! |
checkmate::assert_number(control$global$conf_level, lower = 0, upper = 1) |
| 500 | ! |
checkmate::assert_subset(control$unstrat$method_ci, c("wald", "waldcc", "ha", "newcombe", "newcombecc"))
|
| 501 | ! |
checkmate::assert_subset(control$unstrat$method_test, c("chisq", "fisher", "schouten"))
|
| 502 | ! |
checkmate::assert_logical(control$unstrat$odds) |
| 503 | ! |
checkmate::assert_subset( |
| 504 | ! |
control$strat$method_ci, c("wald", "waldcc", "cmh", "ha", "strat_newcombe", "strat_newcombecc")
|
| 505 |
) |
|
| 506 | ! |
checkmate::assert_subset(control$strat$method_test, c("cmh"))
|
| 507 | ||
| 508 | ! |
args <- as.list(environment()) |
| 509 | ||
| 510 | ! |
data_extract_list <- list( |
| 511 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 512 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 513 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 514 | ! |
strata_var = cs_to_des_select(strata_var, dataname = parentname, multiple = TRUE) |
| 515 |
) |
|
| 516 | ||
| 517 | ! |
module( |
| 518 | ! |
label = label, |
| 519 | ! |
ui = ui_t_binary_outcome, |
| 520 | ! |
ui_args = c(data_extract_list, args), |
| 521 | ! |
server = srv_t_binary_outcome, |
| 522 | ! |
server_args = c( |
| 523 | ! |
data_extract_list, |
| 524 | ! |
list( |
| 525 | ! |
dataname = dataname, |
| 526 | ! |
parentname = parentname, |
| 527 | ! |
arm_ref_comp = arm_ref_comp, |
| 528 | ! |
label = label, |
| 529 | ! |
total_label = total_label, |
| 530 | ! |
default_responses = default_responses, |
| 531 | ! |
control = control, |
| 532 | ! |
rsp_table = rsp_table, |
| 533 | ! |
na_level = na_level, |
| 534 | ! |
basic_table_args = basic_table_args |
| 535 |
) |
|
| 536 |
), |
|
| 537 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 538 |
) |
|
| 539 |
} |
|
| 540 | ||
| 541 |
#' @keywords internal |
|
| 542 |
ui_t_binary_outcome <- function(id, ...) {
|
|
| 543 | ! |
a <- list(...) |
| 544 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 545 | ! |
a$paramcd, |
| 546 | ! |
a$arm_var, |
| 547 | ! |
a$aval_var, |
| 548 | ! |
a$strata_var |
| 549 |
) |
|
| 550 | ||
| 551 | ! |
ns <- NS(id) |
| 552 | ! |
teal.widgets::standard_layout( |
| 553 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 554 | ! |
encoding = tags$div( |
| 555 |
### Reporter |
|
| 556 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 557 |
### |
|
| 558 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 559 | ! |
teal.transform::datanames_input(a[c("paramcd", "arm_var", "aval_var", "strata_var")]),
|
| 560 | ! |
teal.transform::data_extract_ui( |
| 561 | ! |
id = ns("paramcd"),
|
| 562 | ! |
label = "Parameter", |
| 563 | ! |
data_extract_spec = a$paramcd, |
| 564 | ! |
is_single_dataset = is_single_dataset_value |
| 565 |
), |
|
| 566 | ! |
selectInput( |
| 567 | ! |
ns("responders"),
|
| 568 | ! |
"Responders", |
| 569 | ! |
choices = NULL, |
| 570 | ! |
selected = NULL, |
| 571 | ! |
multiple = TRUE |
| 572 |
), |
|
| 573 | ! |
teal.transform::data_extract_ui( |
| 574 | ! |
id = ns("arm_var"),
|
| 575 | ! |
label = "Select Treatment Variable", |
| 576 | ! |
data_extract_spec = a$arm_var, |
| 577 | ! |
is_single_dataset = is_single_dataset_value |
| 578 |
), |
|
| 579 | ! |
tags$div( |
| 580 | ! |
class = "arm-comp-box", |
| 581 | ! |
tags$label("Compare Treatments"),
|
| 582 | ! |
shinyWidgets::switchInput( |
| 583 | ! |
inputId = ns("compare_arms"),
|
| 584 | ! |
value = !is.null(a$arm_ref_comp), |
| 585 | ! |
size = "mini" |
| 586 |
), |
|
| 587 | ! |
conditionalPanel( |
| 588 | ! |
condition = paste0("input['", ns("compare_arms"), "']"),
|
| 589 | ! |
tags$div( |
| 590 | ! |
uiOutput( |
| 591 | ! |
ns("arms_buckets"),
|
| 592 | ! |
title = paste( |
| 593 | ! |
"Multiple reference groups are automatically combined into a single group when more than one", |
| 594 | ! |
"value is selected." |
| 595 |
) |
|
| 596 |
), |
|
| 597 | ! |
helpText("Multiple reference groups are automatically combined into a single group."),
|
| 598 | ! |
checkboxInput( |
| 599 | ! |
ns("combine_comp_arms"),
|
| 600 | ! |
"Combine all comparison groups?", |
| 601 | ! |
value = FALSE |
| 602 |
) |
|
| 603 |
) |
|
| 604 |
) |
|
| 605 |
), |
|
| 606 | ! |
conditionalPanel( |
| 607 | ! |
condition = paste0("input['", ns("compare_arms"), "']"),
|
| 608 | ! |
teal.widgets::panel_group( |
| 609 | ! |
teal.widgets::panel_item( |
| 610 | ! |
"Unstratified analysis settings", |
| 611 | ! |
teal.widgets::optionalSelectInput( |
| 612 | ! |
ns("u_diff_ci"),
|
| 613 | ! |
label = "Method for Difference of Proportions CI", |
| 614 | ! |
choices = c( |
| 615 | ! |
"Wald, without correction" = "wald", |
| 616 | ! |
"Wald, with correction" = "waldcc", |
| 617 | ! |
"Anderson-Hauck" = "ha", |
| 618 | ! |
"Newcombe, without correction" = "newcombe", |
| 619 | ! |
"Newcombe, with correction" = "newcombecc" |
| 620 |
), |
|
| 621 | ! |
selected = a$control$unstrat$method_ci, |
| 622 | ! |
multiple = FALSE, |
| 623 | ! |
fixed = FALSE |
| 624 |
), |
|
| 625 | ! |
teal.widgets::optionalSelectInput( |
| 626 | ! |
ns("u_diff_test"),
|
| 627 | ! |
label = "Method for Difference of Proportions Test", |
| 628 | ! |
choices = c( |
| 629 | ! |
"Chi-squared Test" = "chisq", |
| 630 | ! |
"Fisher's Exact Test" = "fisher", |
| 631 | ! |
"Chi-Squared Test with Schouten correction" = "schouten" |
| 632 |
), |
|
| 633 | ! |
selected = a$control$unstrat$method_test, |
| 634 | ! |
multiple = FALSE, |
| 635 | ! |
fixed = FALSE |
| 636 |
), |
|
| 637 | ! |
tags$label("Odds Ratio Estimation"),
|
| 638 | ! |
shinyWidgets::switchInput( |
| 639 | ! |
inputId = ns("u_odds_ratio"), value = a$control$unstrat$odds, size = "mini"
|
| 640 |
) |
|
| 641 |
) |
|
| 642 |
), |
|
| 643 | ! |
teal.widgets::panel_group( |
| 644 | ! |
teal.widgets::panel_item( |
| 645 | ! |
"Stratified analysis settings", |
| 646 | ! |
teal.transform::data_extract_ui( |
| 647 | ! |
id = ns("strata_var"),
|
| 648 | ! |
label = "Stratification Factors", |
| 649 | ! |
data_extract_spec = a$strata_var, |
| 650 | ! |
is_single_dataset = is_single_dataset_value |
| 651 |
), |
|
| 652 | ! |
teal.widgets::optionalSelectInput( |
| 653 | ! |
ns("s_diff_ci"),
|
| 654 | ! |
label = "Method for Difference of Proportions CI", |
| 655 | ! |
choices = c( |
| 656 | ! |
"Wald, without correction" = "wald", |
| 657 | ! |
"Wald, with correction" = "waldcc", |
| 658 | ! |
"CMH, without correction" = "cmh", |
| 659 | ! |
"Anderson-Hauck" = "ha", |
| 660 | ! |
"Stratified Newcombe, without correction" = "strat_newcombe", |
| 661 | ! |
"Stratified Newcombe, with correction" = "strat_newcombecc" |
| 662 |
), |
|
| 663 | ! |
selected = a$control$strat$method_ci, |
| 664 | ! |
multiple = FALSE |
| 665 |
), |
|
| 666 | ! |
teal.widgets::optionalSelectInput( |
| 667 | ! |
ns("s_diff_test"),
|
| 668 | ! |
label = "Method for Difference of Proportions Test", |
| 669 | ! |
choices = c("CMH Test" = "cmh"),
|
| 670 | ! |
selected = a$control$strat$method_test, |
| 671 | ! |
multiple = FALSE, |
| 672 | ! |
fixed = TRUE |
| 673 |
) |
|
| 674 |
) |
|
| 675 |
) |
|
| 676 |
), |
|
| 677 | ! |
conditionalPanel( |
| 678 | ! |
condition = paste0("!input['", ns("compare_arms"), "']"),
|
| 679 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total)
|
| 680 |
), |
|
| 681 | ! |
teal.widgets::panel_item( |
| 682 | ! |
"Additional table settings", |
| 683 | ! |
teal.widgets::optionalSelectInput( |
| 684 | ! |
inputId = ns("prop_ci_method"),
|
| 685 | ! |
label = "Method for Proportion CI", |
| 686 | ! |
choices = c( |
| 687 | ! |
"Wald, without correction" = "wald", |
| 688 | ! |
"Wald, with correction" = "waldcc", |
| 689 | ! |
"Clopper-Pearson" = "clopper-pearson", |
| 690 | ! |
"Wilson" = "wilson", |
| 691 | ! |
"Wilson, with correction" = "wilsonc", |
| 692 | ! |
"Jeffreys" = "jeffreys", |
| 693 | ! |
"Agresti-Coull" = "agresti-coull" |
| 694 |
), |
|
| 695 | ! |
selected = a$control$global$method, |
| 696 | ! |
multiple = FALSE, |
| 697 | ! |
fixed = FALSE |
| 698 |
), |
|
| 699 | ! |
teal.widgets::optionalSelectInput( |
| 700 | ! |
inputId = ns("conf_level"),
|
| 701 | ! |
label = "Confidence Level", |
| 702 | ! |
a$conf_level$choices, |
| 703 | ! |
a$conf_level$selected, |
| 704 | ! |
multiple = FALSE, |
| 705 | ! |
fixed = a$conf_level$fixed |
| 706 |
), |
|
| 707 | ! |
tags$label("Show All Response Categories"),
|
| 708 | ! |
shinyWidgets::switchInput( |
| 709 | ! |
inputId = ns("show_rsp_cat"),
|
| 710 | ! |
value = ifelse(a$rsp_table, TRUE, FALSE), |
| 711 | ! |
size = "mini" |
| 712 |
) |
|
| 713 |
), |
|
| 714 | ! |
teal.transform::data_extract_ui( |
| 715 | ! |
id = ns("aval_var"),
|
| 716 | ! |
label = "Analysis Variable", |
| 717 | ! |
data_extract_spec = a$aval_var, |
| 718 | ! |
is_single_dataset = is_single_dataset_value |
| 719 |
) |
|
| 720 |
), |
|
| 721 | ! |
forms = tagList( |
| 722 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 723 |
), |
|
| 724 | ! |
pre_output = a$pre_output, |
| 725 | ! |
post_output = a$post_output |
| 726 |
) |
|
| 727 |
} |
|
| 728 | ||
| 729 |
#' @keywords internal |
|
| 730 |
srv_t_binary_outcome <- function(id, |
|
| 731 |
data, |
|
| 732 |
reporter, |
|
| 733 |
filter_panel_api, |
|
| 734 |
dataname, |
|
| 735 |
parentname, |
|
| 736 |
paramcd, |
|
| 737 |
aval_var, |
|
| 738 |
arm_var, |
|
| 739 |
arm_ref_comp, |
|
| 740 |
strata_var, |
|
| 741 |
add_total, |
|
| 742 |
control, |
|
| 743 |
total_label, |
|
| 744 |
label, |
|
| 745 |
default_responses, |
|
| 746 |
rsp_table, |
|
| 747 |
na_level, |
|
| 748 |
basic_table_args) {
|
|
| 749 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 750 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 751 | ! |
checkmate::assert_class(data, "reactive") |
| 752 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 753 | ||
| 754 | ! |
moduleServer(id, function(input, output, session) {
|
| 755 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 756 |
# Setup arm variable selection, default reference arms, and default |
|
| 757 |
# comparison arms for encoding panel |
|
| 758 | ! |
iv_arm_ref <- arm_ref_comp_observer( |
| 759 | ! |
session, |
| 760 | ! |
input, |
| 761 | ! |
output, |
| 762 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 763 | ! |
data = data()[[parentname]], |
| 764 | ! |
arm_ref_comp = arm_ref_comp, |
| 765 | ! |
module = "tm_t_binary_outcome", |
| 766 | ! |
on_off = reactive(input$compare_arms) |
| 767 |
) |
|
| 768 | ||
| 769 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 770 | ! |
data_extract = list(arm_var = arm_var, paramcd = paramcd, strata_var = strata_var, aval_var = aval_var), |
| 771 | ! |
datasets = data, |
| 772 | ! |
select_validation_rule = list( |
| 773 | ! |
aval_var = shinyvalidate::sv_required("An analysis variable is required"),
|
| 774 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required")
|
| 775 |
), |
|
| 776 | ! |
filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select a filter.")) |
| 777 |
) |
|
| 778 | ||
| 779 | ! |
iv_r <- reactive({
|
| 780 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 781 | ||
| 782 | ! |
if (isTRUE(input$compare_arms)) {
|
| 783 | ! |
iv$add_validator(iv_arm_ref) |
| 784 |
} |
|
| 785 | ||
| 786 | ! |
iv$add_rule("responders", shinyvalidate::sv_required("`Responders` field is empty"))
|
| 787 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level between 0 and 1"))
|
| 788 | ! |
iv$add_rule( |
| 789 | ! |
"conf_level", |
| 790 | ! |
shinyvalidate::sv_between(0, 1, message_fmt = "Please choose a confidence level between {left} and {right}")
|
| 791 |
) |
|
| 792 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list, c("arm_var", "aval_var", "paramcd"))
|
| 793 |
}) |
|
| 794 | ||
| 795 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 796 | ! |
datasets = data, |
| 797 | ! |
selector_list = selector_list, |
| 798 | ! |
merge_function = "dplyr::inner_join" |
| 799 |
) |
|
| 800 | ||
| 801 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 802 | ! |
datasets = data, |
| 803 | ! |
data_extract = list(arm_var = arm_var, strata_var = strata_var), |
| 804 | ! |
anl_name = "ANL_ADSL" |
| 805 |
) |
|
| 806 | ||
| 807 | ! |
anl_q <- reactive({
|
| 808 | ! |
data() %>% |
| 809 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 810 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 811 |
}) |
|
| 812 | ||
| 813 | ! |
observeEvent( |
| 814 | ! |
c( |
| 815 | ! |
input[[extract_input("aval_var", "ADRS")]],
|
| 816 | ! |
input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]]
|
| 817 |
), |
|
| 818 | ! |
handlerExpr = {
|
| 819 | ! |
anl <- anl_q()[["ANL"]] |
| 820 | ! |
aval_var <- anl_inputs()$columns_source$aval_var |
| 821 | ! |
paramcd <- input[[extract_input("paramcd", paramcd$filter[[1]]$dataname, filter = TRUE)]]
|
| 822 | ! |
sel_param <- if (is.list(default_responses) && (!is.null(paramcd))) {
|
| 823 | ! |
default_responses[[paramcd]] |
| 824 |
} else {
|
|
| 825 | ! |
default_responses |
| 826 |
} |
|
| 827 | ! |
common_rsp <- if (is.list(sel_param)) {
|
| 828 | ! |
sel_param$rsp |
| 829 |
} else {
|
|
| 830 | ! |
sel_param |
| 831 |
} |
|
| 832 | ! |
responder_choices <- if (length(aval_var) == 0) {
|
| 833 | ! |
character(0) |
| 834 |
} else {
|
|
| 835 | ! |
if ("levels" %in% names(sel_param)) {
|
| 836 | ! |
if (length(intersect(unique(anl[[aval_var]]), sel_param$levels)) > 1) {
|
| 837 | ! |
sel_param$levels |
| 838 |
} else {
|
|
| 839 | ! |
unique(anl[[aval_var]]) |
| 840 |
} |
|
| 841 |
} else {
|
|
| 842 | ! |
unique(anl[[aval_var]]) |
| 843 |
} |
|
| 844 |
} |
|
| 845 | ! |
updateSelectInput( |
| 846 | ! |
session, "responders", |
| 847 | ! |
choices = responder_choices, |
| 848 | ! |
selected = intersect(responder_choices, common_rsp) |
| 849 |
) |
|
| 850 |
} |
|
| 851 |
) |
|
| 852 | ||
| 853 | ! |
validate_check <- reactive({
|
| 854 | ! |
teal::validate_inputs(iv_r()) |
| 855 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 856 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 857 | ! |
anl <- anl_q()[["ANL"]] |
| 858 | ||
| 859 | ! |
anl_m <- anl_inputs() |
| 860 | ! |
input_arm_var <- as.vector(anl_m$columns_source$arm_var) |
| 861 | ! |
input_strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 862 | ! |
input_aval_var <- as.vector(anl_m$columns_source$aval_var) |
| 863 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 864 | ||
| 865 | ! |
validate_args <- list( |
| 866 | ! |
adsl = adsl_filtered, |
| 867 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var, input_strata_var),
|
| 868 | ! |
anl = anl_filtered, |
| 869 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_aval_var),
|
| 870 | ! |
arm_var = input_arm_var |
| 871 |
) |
|
| 872 | ||
| 873 | ! |
if (length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) == 1) {
|
| 874 | ! |
validate_args <- c(validate_args, list(min_n_levels_armvar = NULL)) |
| 875 |
} |
|
| 876 | ! |
if (isTRUE(input$compare_arms)) {
|
| 877 | ! |
validate_args <- c( |
| 878 | ! |
validate_args, |
| 879 | ! |
list(ref_arm = unlist(input$buckets$Ref), comp_arm = unlist(input$buckets$Comp)) |
| 880 |
) |
|
| 881 |
} |
|
| 882 | ||
| 883 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 884 | ||
| 885 | ! |
teal::validate_one_row_per_id(anl, key = c("USUBJID", "STUDYID", input_paramcd))
|
| 886 | ||
| 887 | ! |
validate( |
| 888 | ! |
if (length(input_strata_var) >= 1L) {
|
| 889 | ! |
need( |
| 890 | ! |
sum( |
| 891 | ! |
vapply( |
| 892 | ! |
anl[input_strata_var], |
| 893 | ! |
FUN = function(x) {
|
| 894 | ! |
length(unique(x)) > 1 |
| 895 |
}, |
|
| 896 | ! |
logical(1) |
| 897 |
) |
|
| 898 | ! |
) > 0, |
| 899 | ! |
"At least one strata variable must have more than one non-empty level after filtering." |
| 900 |
) |
|
| 901 |
} |
|
| 902 |
) |
|
| 903 | ||
| 904 | ! |
validate( |
| 905 | ! |
if (length(input_strata_var) >= 1L) {
|
| 906 | ! |
need( |
| 907 | ! |
sum( |
| 908 | ! |
vapply( |
| 909 | ! |
anl[input_strata_var], |
| 910 | ! |
FUN = function(strata) {
|
| 911 | ! |
tab <- base::table(strata, anl[[input_arm_var]]) |
| 912 | ! |
tab_logic <- tab != 0L |
| 913 | ! |
sum(apply(tab_logic, 1, sum) == ncol(tab_logic)) >= 2 |
| 914 |
}, |
|
| 915 | ! |
FUN.VALUE = logical(1) |
| 916 |
) |
|
| 917 | ! |
) > 0, |
| 918 | ! |
"At least one strata variable must have at least two levels with observation(s) in all of the arms." |
| 919 |
) |
|
| 920 |
} |
|
| 921 |
) |
|
| 922 | ||
| 923 | ! |
if (is.list(default_responses)) {
|
| 924 | ! |
validate( |
| 925 | ! |
need( |
| 926 | ! |
all( |
| 927 | ! |
grepl("\\.rsp|\\.levels", names(unlist(default_responses))) |
|
| 928 | ! |
gsub("[0-9]*", "", names(unlist(default_responses))) %in% names(default_responses)
|
| 929 |
), |
|
| 930 | ! |
"The lists given for each AVAL in default_responses must be named 'rsp' and 'levels'." |
| 931 |
) |
|
| 932 |
) |
|
| 933 |
} |
|
| 934 | ||
| 935 | ! |
NULL |
| 936 |
}) |
|
| 937 | ||
| 938 | ! |
table_q <- reactive({
|
| 939 | ! |
validate_check() |
| 940 | ||
| 941 | ! |
qenv <- anl_q() |
| 942 | ! |
anl_m <- anl_inputs() |
| 943 | ! |
anl <- qenv[["ANL"]] |
| 944 | ||
| 945 | ! |
input_aval_var <- as.vector(anl_m$columns_source$aval_var) |
| 946 | ! |
req(input$responders %in% anl[[input_aval_var]]) |
| 947 | ||
| 948 | ! |
input_strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 949 | ! |
input_paramcd <- unlist(anl_m$filter_info$paramcd)["selected"] |
| 950 | ||
| 951 | ! |
responder_val_levels <- as.character(unique(anl[[input_aval_var]])) |
| 952 | ! |
final_responder <- if (is.list(default_responses)) {
|
| 953 | ! |
default_responses[[input_paramcd]][["levels"]] |
| 954 |
} else {
|
|
| 955 | ! |
responder_val_levels |
| 956 |
} |
|
| 957 | ! |
if (length(final_responder) == 0) final_responder <- input$responders |
| 958 | ||
| 959 | ! |
my_calls <- template_binary_outcome( |
| 960 | ! |
dataname = "ANL", |
| 961 | ! |
parentname = "ANL_ADSL", |
| 962 | ! |
arm_var = as.vector(anl_m$columns_source$arm_var), |
| 963 | ! |
paramcd = input_paramcd, |
| 964 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 965 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 966 | ! |
compare_arm = input$compare_arms, |
| 967 | ! |
combine_comp_arms = input$combine_comp_arms && input$compare_arms, |
| 968 | ! |
aval_var = input_aval_var, |
| 969 | ! |
responder_val = input$responders, |
| 970 | ! |
responder_val_levels = final_responder, |
| 971 | ! |
show_rsp_cat = input$show_rsp_cat, |
| 972 | ! |
control = list( |
| 973 | ! |
global = list( |
| 974 | ! |
method = input$prop_ci_method, |
| 975 | ! |
conf_level = as.numeric(input$conf_level) |
| 976 |
), |
|
| 977 | ! |
unstrat = list( |
| 978 | ! |
method_ci = input$u_diff_ci, |
| 979 | ! |
method_test = input$u_diff_test, |
| 980 | ! |
odds = input$u_odds_ratio |
| 981 |
), |
|
| 982 | ! |
strat = list( |
| 983 | ! |
method_ci = input$s_diff_ci, |
| 984 | ! |
method_test = input$s_diff_test, |
| 985 | ! |
strat = if (length(input_strata_var) != 0) input_strata_var else NULL |
| 986 |
) |
|
| 987 |
), |
|
| 988 | ! |
add_total = input$add_total, |
| 989 | ! |
total_label = total_label, |
| 990 | ! |
na_level = na_level, |
| 991 | ! |
basic_table_args = basic_table_args |
| 992 |
) |
|
| 993 | ||
| 994 | ! |
teal.code::eval_code(qenv, as.expression(my_calls)) |
| 995 |
}) |
|
| 996 | ||
| 997 |
# Outputs to render. |
|
| 998 | ! |
table_r <- reactive(table_q()[["result"]]) |
| 999 | ||
| 1000 | ! |
teal.widgets::table_with_settings_srv( |
| 1001 | ! |
id = "table", |
| 1002 | ! |
table_r = table_r |
| 1003 |
) |
|
| 1004 | ||
| 1005 |
# Render R code. |
|
| 1006 | ! |
teal.widgets::verbatim_popup_srv( |
| 1007 | ! |
id = "rcode", |
| 1008 | ! |
verbatim_content = reactive({
|
| 1009 | ! |
teal.code::get_code(table_q()) |
| 1010 |
}), |
|
| 1011 | ! |
title = label |
| 1012 |
) |
|
| 1013 | ||
| 1014 |
### REPORTER |
|
| 1015 | ! |
if (with_reporter) {
|
| 1016 | ! |
card_fun <- function(comment, label) {
|
| 1017 | ! |
card <- teal::report_card_template( |
| 1018 | ! |
title = "Binary Outcome Table", |
| 1019 | ! |
label = label, |
| 1020 | ! |
with_filter = with_filter, |
| 1021 | ! |
filter_panel_api = filter_panel_api |
| 1022 |
) |
|
| 1023 | ! |
card$append_text("Table", "header3")
|
| 1024 | ! |
card$append_table(table_r()) |
| 1025 | ! |
if (!comment == "") {
|
| 1026 | ! |
card$append_text("Comment", "header3")
|
| 1027 | ! |
card$append_text(comment) |
| 1028 |
} |
|
| 1029 | ! |
card$append_src(teal.code::get_code(table_q())) |
| 1030 | ! |
card |
| 1031 |
} |
|
| 1032 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1033 |
} |
|
| 1034 |
### |
|
| 1035 |
}) |
|
| 1036 |
} |
| 1 |
#' Template: Line Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a [ggplot2::ggplot()] line plot. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams tern::g_lineplot |
|
| 6 |
#' @inheritParams tern::control_lineplot_vars |
|
| 7 |
#' @inheritParams template_arguments |
|
| 8 |
#' @param strata (`string` or `NA`)\cr group variable name. |
|
| 9 |
#' @param param (`character`)\cr parameter to filter the data by. |
|
| 10 |
#' @param incl_screen (`logical`)\cr whether the screening visit should be included. |
|
| 11 |
#' @param ggplot2_args (`ggplot2_args`) optional\cr object created by [teal.widgets::ggplot2_args()] with settings |
|
| 12 |
#' for the module plot. For this module, this argument will only accept `ggplot2_args` object with `labs` list of |
|
| 13 |
#' following child elements: `title`, `subtitle`, `caption`, `y`, `lty`. No other elements would be taken into |
|
| 14 |
#' account. The argument is merged with option `teal.ggplot2_args` and with default module arguments (hard coded in |
|
| 15 |
#' the module body). |
|
| 16 |
#' |
|
| 17 |
#' For more details, see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`.
|
|
| 18 |
#' |
|
| 19 |
#' @inherit template_arguments return |
|
| 20 |
#' |
|
| 21 |
#' @seealso [tm_g_lineplot()] |
|
| 22 |
#' |
|
| 23 |
#' @keywords internal |
|
| 24 |
template_g_lineplot <- function(dataname = "ANL", |
|
| 25 |
strata = "ARM", |
|
| 26 |
x = "AVISIT", |
|
| 27 |
y = "AVAL", |
|
| 28 |
y_unit = "AVALU", |
|
| 29 |
paramcd = "PARAMCD", |
|
| 30 |
param = "ALT", |
|
| 31 |
mid = "mean", |
|
| 32 |
interval = "mean_ci", |
|
| 33 |
whiskers = c("mean_ci_lwr", "mean_ci_upr"),
|
|
| 34 |
table = c("n", "mean_sd", "median", "range"),
|
|
| 35 |
mid_type = "pl", |
|
| 36 |
conf_level = 0.95, |
|
| 37 |
incl_screen = TRUE, |
|
| 38 |
mid_point_size = 2, |
|
| 39 |
table_font_size = 4, |
|
| 40 |
title = "Line Plot", |
|
| 41 |
y_lab = "", |
|
| 42 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 43 | 2x |
checkmate::assert_string(dataname) |
| 44 | 2x |
checkmate::assert_string(strata) |
| 45 | 2x |
checkmate::assert_string(x) |
| 46 | 2x |
checkmate::assert_string(y) |
| 47 | 2x |
checkmate::assert_string(y_unit) |
| 48 | 2x |
checkmate::assert_string(paramcd) |
| 49 | 2x |
checkmate::assert_string(title) |
| 50 | 2x |
checkmate::assert_string(y_lab) |
| 51 | ||
| 52 | 2x |
z <- list() |
| 53 | ||
| 54 | 2x |
data_list <- list() |
| 55 | ||
| 56 | 2x |
data_list <- add_expr( |
| 57 | 2x |
data_list, |
| 58 | 2x |
substitute( |
| 59 | 2x |
expr = anl, |
| 60 | 2x |
env = list(anl = as.name(dataname)) |
| 61 |
) |
|
| 62 |
) |
|
| 63 | ||
| 64 | 2x |
if (!incl_screen) {
|
| 65 | 1x |
data_list <- add_expr( |
| 66 | 1x |
data_list, |
| 67 | 1x |
substitute_names( |
| 68 | 1x |
expr = dplyr::filter(x_var != "SCREENING") %>% |
| 69 | 1x |
dplyr::mutate(x_var = factor(x_var)), |
| 70 | 1x |
names = list(x_var = as.name(x)) |
| 71 |
) |
|
| 72 |
) |
|
| 73 |
} |
|
| 74 | ||
| 75 |
# droplevels for strata |
|
| 76 | 2x |
data_list <- add_expr( |
| 77 | 2x |
data_list, |
| 78 | 2x |
substitute_names( |
| 79 | 2x |
expr = dplyr::mutate( |
| 80 | 2x |
arm_var = droplevels(arm_var) |
| 81 |
), |
|
| 82 | 2x |
names = list( |
| 83 | 2x |
arm_var = as.name(strata) |
| 84 |
) |
|
| 85 |
) |
|
| 86 |
) |
|
| 87 | ||
| 88 | 2x |
z$data <- substitute( |
| 89 | 2x |
expr = {
|
| 90 | ! |
anl <- data_pipe |
| 91 |
}, |
|
| 92 | 2x |
env = list( |
| 93 | 2x |
data_pipe = pipe_expr(data_list) |
| 94 |
) |
|
| 95 |
) |
|
| 96 | ||
| 97 | 2x |
z$variables <- substitute( |
| 98 | 2x |
expr = variables <- control_lineplot_vars(x = x, y = y, group_var = arm, paramcd = paramcd, y_unit = y_unit), |
| 99 | 2x |
env = list(x = x, y = y, arm = strata, paramcd = paramcd, y_unit = y_unit) |
| 100 |
) |
|
| 101 | ||
| 102 | 2x |
mid_choices <- c( |
| 103 | 2x |
"Mean" = "mean", |
| 104 | 2x |
"Median" = "median" |
| 105 |
) |
|
| 106 | ||
| 107 | 2x |
interval_choices <- c( |
| 108 | 2x |
"Mean Confidence Interval" = "mean_ci", |
| 109 | 2x |
"Median Confidence Interval" = "median_ci", |
| 110 | 2x |
"25% and 75% Quantiles" = "quantiles", |
| 111 | 2x |
"Range" = "range" |
| 112 |
) |
|
| 113 | ||
| 114 | 2x |
graph_list <- list() |
| 115 | ||
| 116 | 2x |
graph_list <- add_expr( |
| 117 | 2x |
graph_list, |
| 118 | 2x |
quote(grid::grid.newpage()) |
| 119 |
) |
|
| 120 | ||
| 121 | 2x |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 122 | 2x |
user_plot = ggplot2_args, |
| 123 | 2x |
module_plot = teal.widgets::ggplot2_args( |
| 124 | 2x |
labs = list( |
| 125 | 2x |
title = paste0( |
| 126 | 2x |
"Plot of ", names(which(mid_choices == mid)), |
| 127 | 2x |
if (!is.null(interval)) {
|
| 128 | 2x |
paste0( |
| 129 | 2x |
" and ", |
| 130 | 2x |
if (interval %in% c("mean_ci", "median_ci")) paste0(conf_level * 100, "% "),
|
| 131 | 2x |
names(which(interval_choices == interval)) |
| 132 |
) |
|
| 133 |
}, |
|
| 134 | 2x |
" of ", y, " by Visit" |
| 135 |
), |
|
| 136 | 2x |
subtitle = "", |
| 137 | 2x |
y = sprintf("%s %s Values for", y, names(which(mid_choices == mid)))
|
| 138 |
) |
|
| 139 |
) |
|
| 140 |
) |
|
| 141 | ||
| 142 | 2x |
plot_call <- substitute( |
| 143 | 2x |
g_lineplot( |
| 144 | 2x |
df = anl, |
| 145 | 2x |
variables = variables, |
| 146 | 2x |
interval = interval, |
| 147 | 2x |
mid = mid, |
| 148 | 2x |
whiskers = whiskers, |
| 149 | 2x |
table = table, |
| 150 | 2x |
mid_type = mid_type, |
| 151 | 2x |
mid_point_size = mid_point_size, |
| 152 | 2x |
table_font_size = table_font_size, |
| 153 | 2x |
newpage = FALSE, |
| 154 | 2x |
title = ggplot2_args_title, |
| 155 | 2x |
subtitle = ggplot2_args_subtitle, |
| 156 | 2x |
caption = ggplot2_args_caption, |
| 157 | 2x |
y_lab = ggplot2_args_ylab, |
| 158 | 2x |
legend_title = ggplot2_args_legend_title, |
| 159 | 2x |
ggtheme = ggplot2::theme_minimal(), |
| 160 | 2x |
control = control_analyze_vars(conf_level = conf_level), |
| 161 | 2x |
subtitle_add_paramcd = FALSE, |
| 162 | 2x |
subtitle_add_unit = FALSE |
| 163 |
), |
|
| 164 | 2x |
env = list( |
| 165 | 2x |
conf_level = conf_level, |
| 166 | 2x |
interval = interval, |
| 167 | 2x |
mid = mid, |
| 168 | 2x |
whiskers = whiskers, |
| 169 | 2x |
table = table, |
| 170 | 2x |
mid_type = mid_type, |
| 171 | 2x |
mid_choices = mid_choices, |
| 172 | 2x |
interval_choices = interval_choices, |
| 173 | 2x |
mid_point_size = mid_point_size, |
| 174 | 2x |
table_font_size = table_font_size, |
| 175 | 2x |
y = y, |
| 176 | 2x |
ggplot2_args_title = all_ggplot2_args$labs$title, |
| 177 | 2x |
ggplot2_args_subtitle = all_ggplot2_args$labs$subtitle, |
| 178 | 2x |
ggplot2_args_caption = all_ggplot2_args$labs$caption, |
| 179 | 2x |
ggplot2_args_ylab = all_ggplot2_args$labs$y, |
| 180 | 2x |
ggplot2_args_legend_title = all_ggplot2_args$labs$lty |
| 181 |
) |
|
| 182 |
) |
|
| 183 | ||
| 184 | 2x |
graph_list <- add_expr( |
| 185 | 2x |
graph_list, |
| 186 | 2x |
substitute( |
| 187 | 2x |
expr = {
|
| 188 | ! |
plot <- plot_call |
| 189 | ! |
plot |
| 190 |
}, |
|
| 191 | 2x |
env = list(plot_call = plot_call) |
| 192 |
) |
|
| 193 |
) |
|
| 194 | ||
| 195 | 2x |
z$graph <- bracket_expr(graph_list) |
| 196 | ||
| 197 | 2x |
z |
| 198 |
} |
|
| 199 | ||
| 200 |
#' teal Module: Line Plot |
|
| 201 |
#' |
|
| 202 |
#' This module produces a [ggplot2::ggplot()] type line plot, with optional summary table, for standard ADaM data. |
|
| 203 |
#' |
|
| 204 |
#' @inheritParams module_arguments |
|
| 205 |
#' @inheritParams template_g_lineplot |
|
| 206 |
#' |
|
| 207 |
#' @inherit module_arguments return seealso |
|
| 208 |
#' |
|
| 209 |
#' @examples |
|
| 210 |
#' library(nestcolor) |
|
| 211 |
#' library(dplyr) |
|
| 212 |
#' library(forcats) |
|
| 213 |
#' |
|
| 214 |
#' ADSL <- tmc_ex_adsl |
|
| 215 |
#' ADLB <- tmc_ex_adlb %>% mutate(AVISIT == fct_reorder(AVISIT, AVISITN, min)) |
|
| 216 |
#' |
|
| 217 |
#' app <- init( |
|
| 218 |
#' data = cdisc_data( |
|
| 219 |
#' ADSL = ADSL, |
|
| 220 |
#' ADLB = ADLB, |
|
| 221 |
#' code = " |
|
| 222 |
#' ADSL <- tmc_ex_adsl |
|
| 223 |
#' ADLB <- tmc_ex_adlb %>% mutate(AVISIT == fct_reorder(AVISIT, AVISITN, min)) |
|
| 224 |
#' " |
|
| 225 |
#' ), |
|
| 226 |
#' modules = modules( |
|
| 227 |
#' tm_g_lineplot( |
|
| 228 |
#' label = "Line Plot", |
|
| 229 |
#' dataname = "ADLB", |
|
| 230 |
#' strata = choices_selected( |
|
| 231 |
#' variable_choices(ADSL, c("ARM", "ARMCD", "ACTARMCD")),
|
|
| 232 |
#' "ARM" |
|
| 233 |
#' ), |
|
| 234 |
#' y = choices_selected( |
|
| 235 |
#' variable_choices(ADLB, c("AVAL", "BASE", "CHG", "PCHG")),
|
|
| 236 |
#' "AVAL" |
|
| 237 |
#' ), |
|
| 238 |
#' param = choices_selected( |
|
| 239 |
#' value_choices(ADLB, "PARAMCD", "PARAM"), |
|
| 240 |
#' "ALT" |
|
| 241 |
#' ) |
|
| 242 |
#' ) |
|
| 243 |
#' ) |
|
| 244 |
#' ) |
|
| 245 |
#' if (interactive()) {
|
|
| 246 |
#' shinyApp(app$ui, app$server) |
|
| 247 |
#' } |
|
| 248 |
#' |
|
| 249 |
#' @export |
|
| 250 |
tm_g_lineplot <- function(label, |
|
| 251 |
dataname, |
|
| 252 |
parentname = ifelse( |
|
| 253 |
inherits(strata, "data_extract_spec"), |
|
| 254 |
teal.transform::datanames_input(strata), |
|
| 255 |
"ADSL" |
|
| 256 |
), |
|
| 257 |
strata = teal.transform::choices_selected( |
|
| 258 |
teal.transform::variable_choices(parentname, c("ARM", "ARMCD", "ACTARMCD")), "ARM"
|
|
| 259 |
), |
|
| 260 |
x = teal.transform::choices_selected( |
|
| 261 |
teal.transform::variable_choices(dataname, "AVISIT"), "AVISIT", |
|
| 262 |
fixed = TRUE |
|
| 263 |
), |
|
| 264 |
y = teal.transform::choices_selected( |
|
| 265 |
teal.transform::variable_choices(dataname, c("AVAL", "BASE", "CHG", "PCHG")), "AVAL"
|
|
| 266 |
), |
|
| 267 |
y_unit = teal.transform::choices_selected( |
|
| 268 |
teal.transform::variable_choices(dataname, "AVALU"), "AVALU", |
|
| 269 |
fixed = TRUE |
|
| 270 |
), |
|
| 271 |
paramcd = teal.transform::choices_selected( |
|
| 272 |
teal.transform::variable_choices(dataname, "PARAMCD"), "PARAMCD", |
|
| 273 |
fixed = TRUE |
|
| 274 |
), |
|
| 275 |
param = teal.transform::choices_selected( |
|
| 276 |
teal.transform::value_choices(dataname, "PARAMCD", "PARAM"), "ALT" |
|
| 277 |
), |
|
| 278 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 279 |
interval = "mean_ci", |
|
| 280 |
mid = "mean", |
|
| 281 |
whiskers = c("mean_ci_lwr", "mean_ci_upr"),
|
|
| 282 |
table = c("n", "mean_sd", "median", "range"),
|
|
| 283 |
mid_type = "pl", |
|
| 284 |
mid_point_size = c(2, 1, 5), |
|
| 285 |
table_font_size = c(4, 2, 6), |
|
| 286 |
plot_height = c(1000L, 200L, 4000L), |
|
| 287 |
plot_width = NULL, |
|
| 288 |
pre_output = NULL, |
|
| 289 |
post_output = NULL, |
|
| 290 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 291 | ! |
message("Initializing tm_g_lineplot")
|
| 292 | ! |
checkmate::assert_string(label) |
| 293 | ! |
checkmate::assert_string(dataname) |
| 294 | ! |
checkmate::assert_string(parentname) |
| 295 | ! |
checkmate::assert_string(mid) |
| 296 | ! |
checkmate::assert_string(interval, null.ok = TRUE) |
| 297 | ! |
whiskers <- match.arg(whiskers) |
| 298 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 299 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 300 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 301 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 302 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 303 | ! |
checkmate::assert_numeric( |
| 304 | ! |
plot_width[1], |
| 305 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 306 |
) |
|
| 307 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 308 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 309 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 310 | ||
| 311 | ! |
args <- as.list(environment()) |
| 312 | ! |
data_extract_list <- list( |
| 313 | ! |
strata = cs_to_des_select(strata, dataname = parentname), |
| 314 | ! |
param = cs_to_des_filter(param, dataname = dataname), |
| 315 | ! |
x = cs_to_des_select(x, dataname = dataname, multiple = FALSE), |
| 316 | ! |
y = cs_to_des_select(y, dataname = dataname, multiple = FALSE), |
| 317 | ! |
y_unit = cs_to_des_select(y_unit, dataname = dataname), |
| 318 | ! |
paramcd = cs_to_des_select(paramcd, dataname = dataname) |
| 319 |
) |
|
| 320 | ||
| 321 | ! |
module( |
| 322 | ! |
label = label, |
| 323 | ! |
server = srv_g_lineplot, |
| 324 | ! |
ui = ui_g_lineplot, |
| 325 | ! |
ui_args = c(data_extract_list, args), |
| 326 | ! |
server_args = c( |
| 327 | ! |
data_extract_list, |
| 328 | ! |
list( |
| 329 | ! |
dataname = dataname, |
| 330 | ! |
label = label, |
| 331 | ! |
parentname = parentname, |
| 332 | ! |
plot_height = plot_height, |
| 333 | ! |
plot_width = plot_width, |
| 334 | ! |
ggplot2_args = ggplot2_args |
| 335 |
) |
|
| 336 |
), |
|
| 337 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 338 |
) |
|
| 339 |
} |
|
| 340 | ||
| 341 |
#' @keywords internal |
|
| 342 |
ui_g_lineplot <- function(id, ...) {
|
|
| 343 | ! |
a <- list(...) |
| 344 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 345 | ! |
a$strata, |
| 346 | ! |
a$paramcd, |
| 347 | ! |
a$x, |
| 348 | ! |
a$param, |
| 349 | ! |
a$y, |
| 350 | ! |
a$y_unit |
| 351 |
) |
|
| 352 | ||
| 353 | ! |
ns <- NS(id) |
| 354 | ! |
teal.widgets::standard_layout( |
| 355 | ! |
output = teal.widgets::white_small_well( |
| 356 | ! |
verbatimTextOutput(outputId = ns("text")),
|
| 357 | ! |
teal.widgets::plot_with_settings_ui( |
| 358 | ! |
id = ns("myplot")
|
| 359 |
) |
|
| 360 |
), |
|
| 361 | ! |
encoding = tags$div( |
| 362 |
### Reporter |
|
| 363 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 364 |
### |
|
| 365 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 366 | ! |
teal.transform::datanames_input(a[c("strata", "paramcd", "x", "y", "y_unit", "param")]),
|
| 367 | ! |
teal.transform::data_extract_ui( |
| 368 | ! |
id = ns("param"),
|
| 369 | ! |
label = "Select Biomarker", |
| 370 | ! |
data_extract_spec = a$param, |
| 371 | ! |
is_single_dataset = is_single_dataset_value |
| 372 |
), |
|
| 373 | ! |
teal.transform::data_extract_ui( |
| 374 | ! |
id = ns("strata"),
|
| 375 | ! |
label = "Select Treatment Variable", |
| 376 | ! |
data_extract_spec = a$strata, |
| 377 | ! |
is_single_dataset = is_single_dataset_value |
| 378 |
), |
|
| 379 | ! |
teal.transform::data_extract_ui( |
| 380 | ! |
id = ns("y"),
|
| 381 | ! |
label = "Analysis Variable", |
| 382 | ! |
data_extract_spec = a$y, |
| 383 | ! |
is_single_dataset = is_single_dataset_value |
| 384 |
), |
|
| 385 | ! |
teal.transform::data_extract_ui( |
| 386 | ! |
id = ns("x"),
|
| 387 | ! |
label = "Time Variable", |
| 388 | ! |
data_extract_spec = a$x, |
| 389 | ! |
is_single_dataset = is_single_dataset_value |
| 390 |
), |
|
| 391 | ! |
selectInput( |
| 392 | ! |
ns("mid"),
|
| 393 | ! |
"Midpoint Statistic", |
| 394 | ! |
choices = c( |
| 395 | ! |
"Mean" = "mean", |
| 396 | ! |
"Median" = "median" |
| 397 |
), |
|
| 398 | ! |
selected = "mean" |
| 399 |
), |
|
| 400 | ! |
teal.widgets::optionalSelectInput( |
| 401 | ! |
ns("interval"),
|
| 402 | ! |
"Interval", |
| 403 | ! |
choices = c( |
| 404 | ! |
"Mean CI" = "mean_ci", |
| 405 | ! |
"Median CI" = "median_ci", |
| 406 | ! |
"25% and 75%-ile" = "quantiles", |
| 407 | ! |
"Min - Max" = "range" |
| 408 |
), |
|
| 409 | ! |
selected = "mean_ci" |
| 410 |
), |
|
| 411 | ! |
checkboxInput( |
| 412 | ! |
ns("incl_screen"),
|
| 413 | ! |
"Include screening visit", |
| 414 | ! |
value = TRUE |
| 415 |
), |
|
| 416 | ! |
teal.widgets::panel_group( |
| 417 | ! |
teal.widgets::panel_item( |
| 418 | ! |
"Additional plot settings", |
| 419 | ! |
teal.widgets::optionalSelectInput( |
| 420 | ! |
ns("conf_level"),
|
| 421 | ! |
"Level of Confidence", |
| 422 | ! |
a$conf_level$choices, |
| 423 | ! |
a$conf_level$selected, |
| 424 | ! |
multiple = FALSE, |
| 425 | ! |
fixed = a$conf_level$fixed |
| 426 |
), |
|
| 427 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 428 | ! |
ns("mid_point_size"),
|
| 429 | ! |
"Midpoint symbol size", |
| 430 | ! |
a$mid_point_size, |
| 431 | ! |
ticks = FALSE |
| 432 |
), |
|
| 433 | ! |
checkboxGroupInput( |
| 434 | ! |
ns("whiskers"),
|
| 435 | ! |
"Whiskers to display", |
| 436 | ! |
choices = c("Upper", "Lower"),
|
| 437 | ! |
selected = c("Upper", "Lower")
|
| 438 |
), |
|
| 439 | ! |
radioButtons( |
| 440 | ! |
ns("mid_type"),
|
| 441 | ! |
label = "Plot type", |
| 442 | ! |
choices = c( |
| 443 | ! |
"Point and line" = "pl", |
| 444 | ! |
"Point" = "p", |
| 445 | ! |
"Line" = "l" |
| 446 |
), |
|
| 447 | ! |
selected = "pl" |
| 448 |
), |
|
| 449 | ! |
teal.transform::data_extract_ui( |
| 450 | ! |
id = ns("y_unit"),
|
| 451 | ! |
label = "Analysis Unit Variable", |
| 452 | ! |
data_extract_spec = a$y_unit, |
| 453 | ! |
is_single_dataset = is_single_dataset_value |
| 454 |
), |
|
| 455 | ! |
teal.transform::data_extract_ui( |
| 456 | ! |
id = ns("paramcd"),
|
| 457 | ! |
label = "Parameter Code Variable", |
| 458 | ! |
data_extract_spec = a$paramcd, |
| 459 | ! |
is_single_dataset = is_single_dataset_value |
| 460 |
) |
|
| 461 |
) |
|
| 462 |
), |
|
| 463 | ! |
teal.widgets::panel_group( |
| 464 | ! |
teal.widgets::panel_item( |
| 465 | ! |
"Additional table settings", |
| 466 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 467 | ! |
ns("table_font_size"),
|
| 468 | ! |
"Table Font Size", |
| 469 | ! |
a$table_font_size, |
| 470 | ! |
ticks = FALSE |
| 471 |
), |
|
| 472 | ! |
checkboxGroupInput( |
| 473 | ! |
ns("table"),
|
| 474 | ! |
label = "Choose the statistics to display in the table", |
| 475 | ! |
choices = c( |
| 476 | ! |
"n" = "n", |
| 477 | ! |
"Mean (SD)" = "mean_sd", |
| 478 | ! |
"Mean CI" = "mean_ci", |
| 479 | ! |
"Median" = "median", |
| 480 | ! |
"Median CI" = "median_ci", |
| 481 | ! |
"25% and 75%-ile" = "quantiles", |
| 482 | ! |
"Min - Max" = "range" |
| 483 |
), |
|
| 484 | ! |
selected = a$table, |
| 485 |
) |
|
| 486 |
) |
|
| 487 |
) |
|
| 488 |
), |
|
| 489 | ! |
forms = tagList( |
| 490 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 491 |
), |
|
| 492 | ! |
pre_output = a$pre_output, |
| 493 | ! |
post_output = a$post_output |
| 494 |
) |
|
| 495 |
} |
|
| 496 | ||
| 497 |
#' @keywords internal |
|
| 498 |
srv_g_lineplot <- function(id, |
|
| 499 |
data, |
|
| 500 |
reporter, |
|
| 501 |
filter_panel_api, |
|
| 502 |
dataname, |
|
| 503 |
parentname, |
|
| 504 |
paramcd, |
|
| 505 |
strata, |
|
| 506 |
x, |
|
| 507 |
y, |
|
| 508 |
param, |
|
| 509 |
y_unit, |
|
| 510 |
label, |
|
| 511 |
plot_height, |
|
| 512 |
plot_width, |
|
| 513 |
ggplot2_args) {
|
|
| 514 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 515 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 516 | ! |
checkmate::assert_class(data, "reactive") |
| 517 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 518 | ||
| 519 | ! |
moduleServer(id, function(input, output, session) {
|
| 520 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 521 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 522 | ! |
data_extract = list(x = x, y = y, strata = strata, paramcd = paramcd, y_unit = y_unit, param = param), |
| 523 | ! |
datasets = data, |
| 524 | ! |
select_validation_rule = list( |
| 525 | ! |
x = shinyvalidate::sv_required("Please select a time variable"),
|
| 526 | ! |
y = shinyvalidate::sv_required("Please select an analysis variable"),
|
| 527 | ! |
strata = shinyvalidate::sv_required("Please select a treatment variable")
|
| 528 |
), |
|
| 529 | ! |
filter_validation_rule = list( |
| 530 | ! |
param = shinyvalidate::sv_required(message = "Please select Biomarker filter.") |
| 531 |
) |
|
| 532 |
) |
|
| 533 | ||
| 534 | ! |
iv_r <- reactive({
|
| 535 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 536 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level"))
|
| 537 | ! |
iv$add_rule( |
| 538 | ! |
"conf_level", |
| 539 | ! |
shinyvalidate::sv_between( |
| 540 | ! |
0, 1, |
| 541 | ! |
message_fmt = "Please choose a confidence level between 0 and 1", inclusive = c(FALSE, FALSE) |
| 542 |
) |
|
| 543 |
) |
|
| 544 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 545 |
}) |
|
| 546 | ||
| 547 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 548 | ! |
datasets = data, |
| 549 | ! |
selector_list = selector_list, |
| 550 | ! |
merge_function = "dplyr::inner_join" |
| 551 |
) |
|
| 552 | ||
| 553 | ! |
anl_q <- reactive({
|
| 554 | ! |
data() %>% |
| 555 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 556 |
}) |
|
| 557 | ||
| 558 | ! |
merged <- list(anl_input_r = anl_inputs, anl_q = anl_q) |
| 559 | ||
| 560 | ! |
validate_checks <- reactive({
|
| 561 | ! |
teal::validate_inputs(iv_r()) |
| 562 | ||
| 563 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 564 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 565 | ||
| 566 | ! |
input_strata <- names(merged$anl_input_r()$columns_source$strata) |
| 567 | ! |
input_x_var <- names(merged$anl_input_r()$columns_source$x) |
| 568 | ! |
input_y <- names(merged$anl_input_r()$columns_source$y) |
| 569 | ! |
input_param <- unlist(param$filter)["vars_selected"] |
| 570 | ! |
input_paramcd <- names(merged$anl_input_r()$columns_source$paramcd) |
| 571 | ! |
input_y_unit <- names(merged$anl_input_r()$columns_source$y_unit) |
| 572 | ||
| 573 |
# validate inputs |
|
| 574 | ! |
validate_args <- list( |
| 575 | ! |
adsl = adsl_filtered, |
| 576 | ! |
adslvars = c("USUBJID", "STUDYID", input_strata),
|
| 577 | ! |
anl = anl_filtered, |
| 578 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_x_var, input_y, input_y_unit, input_param),
|
| 579 | ! |
arm_var = input_strata |
| 580 |
) |
|
| 581 | ||
| 582 |
# validate arm levels |
|
| 583 | ! |
if (length(input_strata) > 0 && length(unique(adsl_filtered[[input_strata]])) == 1) {
|
| 584 | ! |
validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) |
| 585 |
} |
|
| 586 | ||
| 587 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 588 | ! |
NULL |
| 589 |
}) |
|
| 590 | ||
| 591 | ! |
all_q <- reactive({
|
| 592 | ! |
validate_checks() |
| 593 | ! |
ANL <- merged$anl_q()[["ANL"]] |
| 594 | ! |
teal::validate_has_data(ANL, 2) |
| 595 | ||
| 596 | ! |
whiskers_selected <- if ("Lower" %in% input$whiskers) 1 else NULL
|
| 597 | ! |
if ("Upper" %in% input$whiskers) whiskers_selected <- c(whiskers_selected, 2)
|
| 598 | ! |
if (is.null(input$interval) || is.null(whiskers_selected)) {
|
| 599 | ! |
input_whiskers <- NULL |
| 600 | ! |
input_interval <- NULL |
| 601 |
} else {
|
|
| 602 | ! |
input_interval <- input$interval |
| 603 | ! |
input_whiskers <- names(tern::s_summary(0)[[input_interval]][whiskers_selected]) |
| 604 |
} |
|
| 605 | ! |
input_param <- as.character(unique(ANL[[names(merged$anl_input_r()$columns_source$param)[1]]])) |
| 606 | ||
| 607 | ! |
my_calls <- template_g_lineplot( |
| 608 | ! |
dataname = "ANL", |
| 609 | ! |
strata = names(merged$anl_input_r()$columns_source$strata), |
| 610 | ! |
y = names(merged$anl_input_r()$columns_source$y), |
| 611 | ! |
x = names(merged$anl_input_r()$columns_source$x), |
| 612 | ! |
paramcd = names(merged$anl_input_r()$columns_source$paramcd), |
| 613 | ! |
y_unit = names(merged$anl_input_r()$columns_source$y_unit), |
| 614 | ! |
conf_level = as.numeric(input$conf_level), |
| 615 | ! |
incl_screen = input$incl_screen, |
| 616 | ! |
mid = input$mid, |
| 617 | ! |
interval = input_interval, |
| 618 | ! |
whiskers = input_whiskers, |
| 619 | ! |
table = input$table, |
| 620 | ! |
mid_type = input$mid_type, |
| 621 | ! |
mid_point_size = input$mid_point_size, |
| 622 | ! |
table_font_size = input$table_font_size, |
| 623 | ! |
ggplot2_args = ggplot2_args |
| 624 |
) |
|
| 625 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 626 |
}) |
|
| 627 | ||
| 628 | ! |
plot_r <- reactive(all_q()[["plot"]]) |
| 629 | ||
| 630 |
# Insert the plot into a plot with settings module from teal.widgets |
|
| 631 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 632 | ! |
id = "myplot", |
| 633 | ! |
plot_r = plot_r, |
| 634 | ! |
height = plot_height, |
| 635 | ! |
width = plot_width |
| 636 |
) |
|
| 637 | ||
| 638 | ! |
teal.widgets::verbatim_popup_srv( |
| 639 | ! |
id = "rcode", |
| 640 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 641 | ! |
title = label |
| 642 |
) |
|
| 643 | ||
| 644 |
### REPORTER |
|
| 645 | ! |
if (with_reporter) {
|
| 646 | ! |
card_fun <- function(comment, label) {
|
| 647 | ! |
card <- teal::report_card_template( |
| 648 | ! |
title = "Line Plot", |
| 649 | ! |
label = label, |
| 650 | ! |
with_filter = with_filter, |
| 651 | ! |
filter_panel_api = filter_panel_api |
| 652 |
) |
|
| 653 | ! |
card$append_text("Plot", "header3")
|
| 654 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 655 | ! |
if (!comment == "") {
|
| 656 | ! |
card$append_text("Comment", "header3")
|
| 657 | ! |
card$append_text(comment) |
| 658 |
} |
|
| 659 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 660 | ! |
card |
| 661 |
} |
|
| 662 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 663 |
} |
|
| 664 |
### |
|
| 665 |
}) |
|
| 666 |
} |
| 1 |
#' Template: Univariable Cox Regression |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a univariable Cox regression analysis. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param control (`list`)\cr list of settings for the analysis (see [control_coxreg()]). |
|
| 7 |
#' @param at (`list` of `numeric`)\cr when the candidate covariate is a `numeric` type variable, use `at` |
|
| 8 |
#' to specify the value of the covariate at which the effect should be estimated. |
|
| 9 |
#' @param append (`logical`)\cr whether the result should be appended to the previous one. |
|
| 10 |
#' |
|
| 11 |
#' @inherit template_arguments return |
|
| 12 |
#' |
|
| 13 |
#' @seealso [template_coxreg_m()], [tm_t_coxreg()] |
|
| 14 |
#' |
|
| 15 |
#' @keywords internal |
|
| 16 |
template_coxreg_u <- function(dataname, |
|
| 17 |
cov_var, |
|
| 18 |
arm_var, |
|
| 19 |
cnsr_var, |
|
| 20 |
aval_var, |
|
| 21 |
ref_arm, |
|
| 22 |
comp_arm, |
|
| 23 |
paramcd, |
|
| 24 |
at = list(), |
|
| 25 |
strata_var = NULL, |
|
| 26 |
combine_comp_arms = FALSE, |
|
| 27 |
control = control_coxreg(), |
|
| 28 |
na_level = default_na_str(), |
|
| 29 |
append = FALSE, |
|
| 30 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 31 | 2x |
y <- list() |
| 32 | 2x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 33 | ||
| 34 | 2x |
data_pipe <- list() |
| 35 | 2x |
data_list <- list() |
| 36 | ||
| 37 | 2x |
data_pipe <- add_expr( |
| 38 | 2x |
data_pipe, |
| 39 | 2x |
prepare_arm( |
| 40 | 2x |
dataname = dataname, |
| 41 | 2x |
arm_var = arm_var, |
| 42 | 2x |
ref_arm = ref_arm, |
| 43 | 2x |
comp_arm = comp_arm, |
| 44 | 2x |
ref_arm_val = ref_arm_val |
| 45 |
) |
|
| 46 |
) |
|
| 47 | ||
| 48 | 2x |
if (combine_comp_arms) {
|
| 49 | ! |
data_pipe <- add_expr( |
| 50 | ! |
data_pipe, |
| 51 | ! |
substitute_names( |
| 52 | ! |
expr = dplyr::mutate(arm_var = combine_levels(x = arm_var, levels = comp_arm)), |
| 53 | ! |
names = list(arm_var = as.name(arm_var)), |
| 54 | ! |
others = list(comp_arm = comp_arm) |
| 55 |
) |
|
| 56 |
) |
|
| 57 |
} |
|
| 58 | ||
| 59 | 2x |
data_pipe <- add_expr( |
| 60 | 2x |
data_pipe, |
| 61 | 2x |
substitute( |
| 62 | 2x |
expr = dplyr::mutate(event = 1 - cnsr_var), |
| 63 | 2x |
env = list(cnsr_var = as.name(cnsr_var)) |
| 64 |
) |
|
| 65 |
) |
|
| 66 | ||
| 67 | 2x |
data_pipe <- add_expr( |
| 68 | 2x |
data_pipe, |
| 69 | 2x |
substitute( |
| 70 | 2x |
expr = dplyr::mutate(across(where(is.factor) & cov_var, droplevels)), |
| 71 | 2x |
env = list(cov_var = cov_var) |
| 72 |
) |
|
| 73 |
) |
|
| 74 | ||
| 75 | 2x |
data_pipe <- add_expr( |
| 76 | 2x |
data_pipe, |
| 77 | 2x |
substitute( |
| 78 | 2x |
expr = df_explicit_na(na_level = na_lvl), |
| 79 | 2x |
env = list(na_lvl = na_level) |
| 80 |
) |
|
| 81 |
) |
|
| 82 | ||
| 83 | 2x |
data_list <- add_expr( |
| 84 | 2x |
data_list, |
| 85 | 2x |
substitute( |
| 86 | 2x |
expr = anl <- data_pipe, |
| 87 | 2x |
env = list(data_pipe = pipe_expr(data_pipe)) |
| 88 |
) |
|
| 89 |
) |
|
| 90 | ||
| 91 | 2x |
data_list <- add_expr( |
| 92 | 2x |
data_list, |
| 93 | 2x |
substitute( |
| 94 | 2x |
expr = control <- ctrl, |
| 95 | 2x |
env = list(ctrl = control) |
| 96 |
) |
|
| 97 |
) |
|
| 98 | ||
| 99 | 2x |
variables <- list(time = aval_var, event = "event", arm = arm_var) |
| 100 | ||
| 101 | ! |
if (!is.null(cov_var)) variables$covariates <- cov_var |
| 102 | 2x |
if (!is.null(strata_var)) variables$strata <- strata_var |
| 103 | ||
| 104 | 2x |
y$data <- bracket_expr(data_list) |
| 105 | ||
| 106 | 2x |
layout_list <- list() |
| 107 | ||
| 108 | 2x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 109 | 2x |
teal.widgets::resolve_basic_table_args( |
| 110 | 2x |
user_table = basic_table_args, |
| 111 | 2x |
module_table = teal.widgets::basic_table_args( |
| 112 | 2x |
title = paste("Multi-Variable Cox Regression for", paramcd),
|
| 113 | 2x |
main_footer = c( |
| 114 | 2x |
paste("p-value method for Coxph (Hazard Ratio):", control$pval_method),
|
| 115 | 2x |
paste("Ties for Coxph (Hazard Ratio):", control$ties)
|
| 116 |
) |
|
| 117 |
) |
|
| 118 |
) |
|
| 119 |
) |
|
| 120 | ||
| 121 | 2x |
layout_list <- add_expr( |
| 122 | 2x |
layout_list, |
| 123 | 2x |
parsed_basic_table_args |
| 124 |
) |
|
| 125 | ||
| 126 | 2x |
layout_list <- add_expr( |
| 127 | 2x |
layout_list, |
| 128 | 2x |
substitute( |
| 129 | 2x |
expr = rtables::append_topleft(paramcd), |
| 130 | 2x |
env = list(paramcd = paramcd) |
| 131 |
) |
|
| 132 |
) |
|
| 133 | ||
| 134 | 2x |
stats <- c("n", "hr", "ci", "pval")
|
| 135 | ||
| 136 | 2x |
layout_list <- add_expr( |
| 137 | 2x |
layout_list, |
| 138 | 2x |
substitute( |
| 139 | 2x |
expr = summarize_coxreg( |
| 140 | 2x |
variables = variables, |
| 141 | 2x |
control = control, |
| 142 | 2x |
at = at, |
| 143 | 2x |
multivar = multivariate, |
| 144 | 2x |
.stats = stats, |
| 145 | 2x |
na_str = na_str |
| 146 |
), |
|
| 147 | 2x |
env = list( |
| 148 | 2x |
multivariate = FALSE, |
| 149 | 2x |
variables = variables, |
| 150 | 2x |
control = control, |
| 151 | 2x |
at = at, |
| 152 | 2x |
stats = if (control$interaction) c(stats, "pval_inter") else stats, |
| 153 | 2x |
na_str = na_level |
| 154 |
) |
|
| 155 |
) |
|
| 156 |
) |
|
| 157 | ||
| 158 | 2x |
y$layout <- substitute( |
| 159 | 2x |
expr = lyt <- layout_pipe, |
| 160 | 2x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 161 |
) |
|
| 162 | ||
| 163 | 2x |
y$table <- if (append) {
|
| 164 | ! |
quote(result <- c(result, rtables::build_table(lyt = lyt, df = anl))) |
| 165 |
} else {
|
|
| 166 | 2x |
quote(result <- rtables::build_table(lyt = lyt, df = anl)) |
| 167 |
} |
|
| 168 | ||
| 169 | 2x |
y |
| 170 |
} |
|
| 171 | ||
| 172 |
#' Template: Multi-Variable Cox Regression |
|
| 173 |
#' |
|
| 174 |
#' Creates a valid expression to generate a multi-variable Cox regression analysis. |
|
| 175 |
#' |
|
| 176 |
#' @inheritParams template_coxreg_u |
|
| 177 |
#' @inheritParams template_arguments |
|
| 178 |
#' |
|
| 179 |
#' @inherit template_arguments return |
|
| 180 |
#' |
|
| 181 |
#' @seealso [template_coxreg_u()], [tm_t_coxreg()] |
|
| 182 |
#' |
|
| 183 |
#' @keywords internal |
|
| 184 |
template_coxreg_m <- function(dataname, |
|
| 185 |
cov_var, |
|
| 186 |
arm_var, |
|
| 187 |
cnsr_var, |
|
| 188 |
aval_var, |
|
| 189 |
ref_arm, |
|
| 190 |
comp_arm, |
|
| 191 |
paramcd, |
|
| 192 |
at = list(), |
|
| 193 |
strata_var = NULL, |
|
| 194 |
combine_comp_arms = FALSE, |
|
| 195 |
control = control_coxreg(), |
|
| 196 |
na_level = default_na_str(), |
|
| 197 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 198 | 1x |
y <- list() |
| 199 | 1x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 200 | ||
| 201 | 1x |
data_pipe <- list() |
| 202 | 1x |
data_list <- list() |
| 203 | ||
| 204 | 1x |
data_pipe <- add_expr( |
| 205 | 1x |
data_pipe, |
| 206 | 1x |
prepare_arm( |
| 207 | 1x |
dataname = dataname, |
| 208 | 1x |
arm_var = arm_var, |
| 209 | 1x |
ref_arm = ref_arm, |
| 210 | 1x |
comp_arm = comp_arm, |
| 211 | 1x |
ref_arm_val = ref_arm_val |
| 212 |
) |
|
| 213 |
) |
|
| 214 | ||
| 215 | 1x |
if (combine_comp_arms) {
|
| 216 | 1x |
data_pipe <- add_expr( |
| 217 | 1x |
data_pipe, |
| 218 | 1x |
substitute_names( |
| 219 | 1x |
expr = dplyr::mutate(arm_var = combine_levels(x = arm_var, levels = comp_arm)), |
| 220 | 1x |
names = list(arm_var = as.name(arm_var)), |
| 221 | 1x |
others = list(comp_arm = comp_arm) |
| 222 |
) |
|
| 223 |
) |
|
| 224 |
} |
|
| 225 | ||
| 226 | 1x |
data_pipe <- add_expr( |
| 227 | 1x |
data_pipe, |
| 228 | 1x |
substitute( |
| 229 | 1x |
expr = dplyr::mutate(event = 1 - cnsr_var), |
| 230 | 1x |
env = list(cnsr_var = as.name(cnsr_var)) |
| 231 |
) |
|
| 232 |
) |
|
| 233 | ||
| 234 | 1x |
data_pipe <- add_expr( |
| 235 | 1x |
data_pipe, |
| 236 | 1x |
substitute( |
| 237 | 1x |
expr = dplyr::mutate(across(where(is.factor) & cov_var, droplevels)), |
| 238 | 1x |
env = list(cov_var = cov_var) |
| 239 |
) |
|
| 240 |
) |
|
| 241 | ||
| 242 | 1x |
data_pipe <- add_expr( |
| 243 | 1x |
data_pipe, |
| 244 | 1x |
substitute( |
| 245 | 1x |
expr = df_explicit_na(na_level = na_lvl), |
| 246 | 1x |
env = list(na_lvl = na_level) |
| 247 |
) |
|
| 248 |
) |
|
| 249 | ||
| 250 | 1x |
data_list <- add_expr( |
| 251 | 1x |
data_list, |
| 252 | 1x |
substitute( |
| 253 | 1x |
expr = anl <- data_pipe, |
| 254 | 1x |
env = list(data_pipe = pipe_expr(data_pipe)) |
| 255 |
) |
|
| 256 |
) |
|
| 257 | ||
| 258 | 1x |
variables <- list(time = aval_var, event = "event", arm = arm_var) |
| 259 | ||
| 260 | 1x |
if (!is.null(cov_var)) variables$covariates <- cov_var |
| 261 | ! |
if (!is.null(strata_var)) variables$strata <- strata_var |
| 262 | ||
| 263 | 1x |
y$data <- bracket_expr(data_list) |
| 264 | ||
| 265 | 1x |
layout_list <- list() |
| 266 | ||
| 267 | 1x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 268 | 1x |
teal.widgets::resolve_basic_table_args( |
| 269 | 1x |
user_table = basic_table_args, |
| 270 | 1x |
module_table = teal.widgets::basic_table_args( |
| 271 | 1x |
title = paste("Cox Regression for", paramcd),
|
| 272 | 1x |
main_footer = c( |
| 273 | 1x |
paste("p-value method for Coxph (Hazard Ratio):", control$pval_method),
|
| 274 | 1x |
paste("Ties for Coxph (Hazard Ratio):", control$ties)
|
| 275 |
) |
|
| 276 |
) |
|
| 277 |
) |
|
| 278 |
) |
|
| 279 | ||
| 280 | 1x |
layout_list <- add_expr( |
| 281 | 1x |
layout_list, |
| 282 | 1x |
parsed_basic_table_args |
| 283 |
) |
|
| 284 | ||
| 285 | 1x |
layout_list <- add_expr( |
| 286 | 1x |
layout_list, |
| 287 | 1x |
substitute( |
| 288 | 1x |
expr = rtables::append_topleft(paramcd), |
| 289 | 1x |
env = list(paramcd = paramcd) |
| 290 |
) |
|
| 291 |
) |
|
| 292 | ||
| 293 | 1x |
stats <- c("hr", "ci", "pval")
|
| 294 | ||
| 295 | 1x |
layout_list <- add_expr( |
| 296 | 1x |
layout_list, |
| 297 | 1x |
substitute( |
| 298 | 1x |
expr = summarize_coxreg( |
| 299 | 1x |
variables = variables, |
| 300 | 1x |
control = control, |
| 301 | 1x |
multivar = multivariate, |
| 302 | 1x |
.stats = stats, |
| 303 | 1x |
na_str = na_str |
| 304 |
), |
|
| 305 | 1x |
env = list( |
| 306 | 1x |
variables = variables, |
| 307 | 1x |
control = control, |
| 308 | 1x |
multivariate = TRUE, |
| 309 | 1x |
stats = stats, |
| 310 | 1x |
na_str = na_level |
| 311 |
) |
|
| 312 |
) |
|
| 313 |
) |
|
| 314 | ||
| 315 | 1x |
y$layout <- substitute( |
| 316 | 1x |
expr = lyt <- layout_pipe, |
| 317 | 1x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 318 |
) |
|
| 319 | ||
| 320 | 1x |
y$table <- quote({
|
| 321 | ! |
result <- rtables::build_table(lyt = lyt, df = anl) |
| 322 | ! |
result |
| 323 |
}) |
|
| 324 | ||
| 325 | 1x |
y |
| 326 |
} |
|
| 327 | ||
| 328 |
#' teal Module: Cox Regression Model |
|
| 329 |
#' |
|
| 330 |
#' This module fits Cox univariable or multi-variable models, consistent with the TLG Catalog |
|
| 331 |
#' templates for Cox regression tables `COXT01` and `COXT02`, respectively. See the TLG Catalog entries |
|
| 332 |
#' for `COXT01` [here](https://insightsengineering.github.io/tlg-catalog/stable/tables/efficacy/coxt01.html) |
|
| 333 |
#' and `COXT02` [here](https://insightsengineering.github.io/tlg-catalog/stable/tables/efficacy/coxt02.html). |
|
| 334 |
#' |
|
| 335 |
#' @inheritParams module_arguments |
|
| 336 |
#' @inheritParams template_coxreg_u |
|
| 337 |
#' @inheritParams template_coxreg_m |
|
| 338 |
#' @param multivariate (`logical`)\cr if `FALSE`, the univariable approach is used instead of the |
|
| 339 |
#' multi-variable model. |
|
| 340 |
#' |
|
| 341 |
#' @details |
|
| 342 |
#' The Cox Proportional Hazards (PH) model is the most commonly used method to |
|
| 343 |
#' estimate the magnitude of the effect in survival analysis. It assumes proportional |
|
| 344 |
#' hazards: the ratio of the hazards between groups (e.g., two arms) is constant over time. |
|
| 345 |
#' This ratio is referred to as the "hazard ratio" (HR) and is one of the most |
|
| 346 |
#' commonly reported metrics to describe the effect size in survival analysis. |
|
| 347 |
#' |
|
| 348 |
#' This modules expects that the analysis data has the following variables: |
|
| 349 |
#' |
|
| 350 |
#' * `AVAL`: time to event |
|
| 351 |
#' * `CNSR`: 1 if record in `AVAL` is censored, 0 otherwise |
|
| 352 |
#' * `PARAMCD`: variable used to filter for endpoint (e.g. OS). After |
|
| 353 |
#' filtering for `PARAMCD` one observation per patient is expected |
|
| 354 |
#' |
|
| 355 |
#' The arm variables and stratification/covariate variables are taken from the `ADSL` data. |
|
| 356 |
#' |
|
| 357 |
#' @note |
|
| 358 |
#' * The likelihood ratio test is not supported for models that include strata - the Wald |
|
| 359 |
#' test will be substituted in these cases. |
|
| 360 |
#' * Multi-variable is the default choice for backward compatibility. |
|
| 361 |
#' |
|
| 362 |
#' @inherit module_arguments return seealso |
|
| 363 |
#' |
|
| 364 |
#' @examples |
|
| 365 |
#' ## First example |
|
| 366 |
#' ## ============= |
|
| 367 |
#' ## The example below is based on the usual approach involving creation of |
|
| 368 |
#' ## a random CDISC dataset and then running the application. |
|
| 369 |
#' |
|
| 370 |
#' arm_ref_comp <- list( |
|
| 371 |
#' ACTARMCD = list( |
|
| 372 |
#' ref = "ARM B", |
|
| 373 |
#' comp = c("ARM A", "ARM C")
|
|
| 374 |
#' ), |
|
| 375 |
#' ARM = list( |
|
| 376 |
#' ref = "B: Placebo", |
|
| 377 |
#' comp = c("A: Drug X", "C: Combination")
|
|
| 378 |
#' ) |
|
| 379 |
#' ) |
|
| 380 |
#' |
|
| 381 |
#' data <- teal_data() |
|
| 382 |
#' data <- within(data, {
|
|
| 383 |
#' ADSL <- tmc_ex_adsl |
|
| 384 |
#' ADTTE <- tmc_ex_adtte |
|
| 385 |
#' }) |
|
| 386 |
#' datanames <- c("ADSL", "ADTTE")
|
|
| 387 |
#' datanames(data) <- datanames |
|
| 388 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 389 |
#' |
|
| 390 |
#' app <- init( |
|
| 391 |
#' data = data, |
|
| 392 |
#' modules = modules( |
|
| 393 |
#' tm_t_coxreg( |
|
| 394 |
#' label = "Cox Reg.", |
|
| 395 |
#' dataname = "ADTTE", |
|
| 396 |
#' arm_var = choices_selected(c("ARM", "ARMCD", "ACTARMCD"), "ARM"),
|
|
| 397 |
#' arm_ref_comp = arm_ref_comp, |
|
| 398 |
#' paramcd = choices_selected( |
|
| 399 |
#' value_choices(data[["ADTTE"]], "PARAMCD", "PARAM"), "OS" |
|
| 400 |
#' ), |
|
| 401 |
#' strata_var = choices_selected( |
|
| 402 |
#' c("COUNTRY", "STRATA1", "STRATA2"), "STRATA1"
|
|
| 403 |
#' ), |
|
| 404 |
#' cov_var = choices_selected( |
|
| 405 |
#' c("AGE", "BMRKR1", "BMRKR2", "REGION1"), "AGE"
|
|
| 406 |
#' ), |
|
| 407 |
#' multivariate = TRUE |
|
| 408 |
#' ) |
|
| 409 |
#' ) |
|
| 410 |
#' ) |
|
| 411 |
#' if (interactive()) {
|
|
| 412 |
#' shinyApp(app$ui, app$server) |
|
| 413 |
#' } |
|
| 414 |
#' |
|
| 415 |
#' ## Second example |
|
| 416 |
#' ## ============== |
|
| 417 |
#' ## This time, a synthetic pair of ADTTE/ADSL data is fabricated for Cox regression |
|
| 418 |
#' ## where ties and pval_method matter. |
|
| 419 |
#' |
|
| 420 |
#' ## Dataset fabrication |
|
| 421 |
#' ## ------------------- |
|
| 422 |
#' |
|
| 423 |
#' data <- teal_data() |
|
| 424 |
#' data <- within(data, {
|
|
| 425 |
#' library(dplyr) |
|
| 426 |
#' ADTTE <- data.frame( |
|
| 427 |
#' STUDYID = "LUNG", |
|
| 428 |
#' AVAL = c(4, 3, 1, 1, 2, 2, 3, 1, 2), |
|
| 429 |
#' CNSR = c(1, 1, 1, 0, 1, 1, 0, 0, 0), |
|
| 430 |
#' ARMCD = factor( |
|
| 431 |
#' c(0, 1, 1, 1, 1, 0, 0, 0, 0), |
|
| 432 |
#' labels = c("ARM A", "ARM B")
|
|
| 433 |
#' ), |
|
| 434 |
#' SEX = factor( |
|
| 435 |
#' c(0, 0, 0, 0, 1, 1, 1, 1, 1), |
|
| 436 |
#' labels = c("F", "M")
|
|
| 437 |
#' ), |
|
| 438 |
#' INST = factor(c("A", "A", "B", "B", "A", "B", "A", "B", "A")),
|
|
| 439 |
#' stringsAsFactors = FALSE |
|
| 440 |
#' ) |
|
| 441 |
#' ADTTE <- rbind(ADTTE, ADTTE, ADTTE, ADTTE) |
|
| 442 |
#' ADTTE <- as_tibble(ADTTE) |
|
| 443 |
#' set.seed(1) |
|
| 444 |
#' ADTTE$INST <- sample(ADTTE$INST) |
|
| 445 |
#' ADTTE$AGE <- sample(seq(5, 75, 5), size = nrow(ADTTE), replace = TRUE) |
|
| 446 |
#' ADTTE$USUBJID <- paste("sub", 1:nrow(ADTTE), ADTTE$INST, sep = "-")
|
|
| 447 |
#' ADTTE$PARAM <- ADTTE$PARAMCD <- "OS" |
|
| 448 |
#' ADSL <- subset( |
|
| 449 |
#' ADTTE, |
|
| 450 |
#' select = c("USUBJID", "STUDYID", "ARMCD", "SEX", "INST", "AGE")
|
|
| 451 |
#' ) |
|
| 452 |
#' }) |
|
| 453 |
#' |
|
| 454 |
#' datanames <- c("ADSL", "ADTTE")
|
|
| 455 |
#' datanames(data) <- datanames |
|
| 456 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 457 |
#' |
|
| 458 |
#' ## `teal` application |
|
| 459 |
#' ## ---------------- |
|
| 460 |
#' ## Note that the R code exported by `Show R Code` does not include the data |
|
| 461 |
#' ## pre-processing. You will need to create the dataset as above before |
|
| 462 |
#' ## running the exported R code. |
|
| 463 |
#' |
|
| 464 |
#' arm_ref_comp <- list(ARMCD = list(ref = "ARM A", comp = c("ARM B")))
|
|
| 465 |
#' app <- init( |
|
| 466 |
#' data = data, |
|
| 467 |
#' modules = modules( |
|
| 468 |
#' tm_t_coxreg( |
|
| 469 |
#' label = "Cox Reg.", |
|
| 470 |
#' dataname = "ADTTE", |
|
| 471 |
#' arm_var = choices_selected(c("ARMCD"), "ARMCD"),
|
|
| 472 |
#' arm_ref_comp = arm_ref_comp, |
|
| 473 |
#' paramcd = choices_selected( |
|
| 474 |
#' value_choices(data[["ADTTE"]], "PARAMCD", "PARAM"), "OS" |
|
| 475 |
#' ), |
|
| 476 |
#' strata_var = choices_selected(c("INST"), NULL),
|
|
| 477 |
#' cov_var = choices_selected(c("SEX", "AGE"), "SEX"),
|
|
| 478 |
#' multivariate = TRUE |
|
| 479 |
#' ) |
|
| 480 |
#' ) |
|
| 481 |
#' ) |
|
| 482 |
#' if (interactive()) {
|
|
| 483 |
#' shinyApp(app$ui, app$server) |
|
| 484 |
#' } |
|
| 485 |
#' |
|
| 486 |
#' @export |
|
| 487 |
tm_t_coxreg <- function(label, |
|
| 488 |
dataname, |
|
| 489 |
parentname = ifelse( |
|
| 490 |
inherits(arm_var, "data_extract_spec"), |
|
| 491 |
teal.transform::datanames_input(arm_var), |
|
| 492 |
"ADSL" |
|
| 493 |
), |
|
| 494 |
arm_var, |
|
| 495 |
arm_ref_comp = NULL, |
|
| 496 |
paramcd, |
|
| 497 |
cov_var, |
|
| 498 |
strata_var, |
|
| 499 |
aval_var = teal.transform::choices_selected( |
|
| 500 |
teal.transform::variable_choices(dataname, "AVAL"), "AVAL", |
|
| 501 |
fixed = TRUE |
|
| 502 |
), |
|
| 503 |
cnsr_var = teal.transform::choices_selected( |
|
| 504 |
teal.transform::variable_choices(dataname, "CNSR"), "CNSR", |
|
| 505 |
fixed = TRUE |
|
| 506 |
), |
|
| 507 |
multivariate = TRUE, |
|
| 508 |
na_level = default_na_str(), |
|
| 509 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 510 |
pre_output = NULL, |
|
| 511 |
post_output = NULL, |
|
| 512 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 513 | ! |
message("Initializing tm_t_coxreg")
|
| 514 | ! |
checkmate::assert_string(label) |
| 515 | ! |
checkmate::assert_string(dataname) |
| 516 | ! |
checkmate::assert_string(parentname) |
| 517 | ! |
checkmate::assert_string(na_level) |
| 518 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 519 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 520 | ! |
checkmate::assert_class(cov_var, "choices_selected") |
| 521 | ! |
checkmate::assert_class(strata_var, "choices_selected") |
| 522 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 523 | ! |
checkmate::assert_class(cnsr_var, "choices_selected") |
| 524 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 525 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 526 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 527 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 528 | ||
| 529 | ! |
args <- as.list(environment()) |
| 530 | ||
| 531 | ! |
data_extract_list <- list( |
| 532 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 533 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname, label = NULL), |
| 534 | ! |
strata_var = cs_to_des_select(strata_var, dataname = parentname, multiple = TRUE), |
| 535 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 536 | ! |
cnsr_var = cs_to_des_select(cnsr_var, dataname = dataname), |
| 537 | ! |
cov_var = cs_to_des_select(cov_var, dataname = parentname, multiple = TRUE, ordered = TRUE) |
| 538 |
) |
|
| 539 | ||
| 540 | ! |
module( |
| 541 | ! |
label = label, |
| 542 | ! |
server = srv_t_coxreg, |
| 543 | ! |
ui = ui_t_coxreg, |
| 544 | ! |
ui_args = c(data_extract_list, args), |
| 545 | ! |
server_args = c( |
| 546 | ! |
data_extract_list, |
| 547 | ! |
list( |
| 548 | ! |
arm_ref_comp = arm_ref_comp, |
| 549 | ! |
dataname = dataname, |
| 550 | ! |
parentname = parentname, |
| 551 | ! |
label = label, |
| 552 | ! |
na_level = na_level, |
| 553 | ! |
basic_table_args = basic_table_args |
| 554 |
) |
|
| 555 |
), |
|
| 556 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 557 |
) |
|
| 558 |
} |
|
| 559 | ||
| 560 |
#' @keywords internal |
|
| 561 |
ui_t_coxreg <- function(id, ...) {
|
|
| 562 | ! |
a <- list(...) # module args |
| 563 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 564 | ! |
a$arm_var, |
| 565 | ! |
a$paramcd, |
| 566 | ! |
a$strata_var, |
| 567 | ! |
a$aval_var, |
| 568 | ! |
a$cnsr_var, |
| 569 | ! |
a$cov_var |
| 570 |
) |
|
| 571 | ||
| 572 | ! |
ns <- NS(id) |
| 573 | ||
| 574 | ! |
teal.widgets::standard_layout( |
| 575 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 576 | ! |
encoding = tags$div( |
| 577 |
### Reporter |
|
| 578 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 579 |
### |
|
| 580 | ! |
radioButtons( |
| 581 | ! |
ns("type"),
|
| 582 | ! |
label = tags$label("Type of Regression:", class = "text-primary"),
|
| 583 | ! |
choices = c( |
| 584 | ! |
"Separate models for comparison groups with one covariate at a time" = "Univariate", |
| 585 | ! |
"One model with all comparison groups and covariates" = "Multivariate" |
| 586 |
), |
|
| 587 | ! |
selected = dplyr::if_else(a$multivariate, "Multivariate", "Univariate") |
| 588 |
), |
|
| 589 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 590 | ! |
teal.transform::datanames_input( |
| 591 | ! |
a[c("arm_var", "paramcd", "subgroup_var", "strata_var", "aval_var", "cnsr_var", "cov_var")]
|
| 592 |
), |
|
| 593 | ! |
teal.transform::data_extract_ui( |
| 594 | ! |
id = ns("paramcd"),
|
| 595 | ! |
label = "Select Endpoint", |
| 596 | ! |
data_extract_spec = a$paramcd, |
| 597 | ! |
is_single_dataset = is_single_dataset_value |
| 598 |
), |
|
| 599 | ! |
teal.transform::data_extract_ui( |
| 600 | ! |
id = ns("cnsr_var"),
|
| 601 | ! |
label = "Censor Variable", |
| 602 | ! |
data_extract_spec = a$cnsr_var, |
| 603 | ! |
is_single_dataset = is_single_dataset_value |
| 604 |
), |
|
| 605 | ! |
teal.transform::data_extract_ui( |
| 606 | ! |
id = ns("aval_var"),
|
| 607 | ! |
label = "Analysis Variable", |
| 608 | ! |
data_extract_spec = a$aval_var, |
| 609 | ! |
is_single_dataset = is_single_dataset_value |
| 610 |
), |
|
| 611 | ! |
teal.transform::data_extract_ui( |
| 612 | ! |
id = ns("arm_var"),
|
| 613 | ! |
label = "Select Treatment Variable", |
| 614 | ! |
data_extract_spec = a$arm_var, |
| 615 | ! |
is_single_dataset = is_single_dataset_value |
| 616 |
), |
|
| 617 | ! |
uiOutput(ns("arms_buckets")),
|
| 618 | ! |
conditionalPanel( |
| 619 | ! |
condition = paste0("input['", ns("type"), "'] == 'Multivariate'"),
|
| 620 | ! |
checkboxInput( |
| 621 | ! |
ns("combine_comp_arms"),
|
| 622 | ! |
"Combine all comparison groups?" |
| 623 |
) |
|
| 624 |
), |
|
| 625 | ! |
teal.transform::data_extract_ui( |
| 626 | ! |
id = ns("cov_var"),
|
| 627 | ! |
label = "Covariates", |
| 628 | ! |
data_extract_spec = a$cov_var, |
| 629 | ! |
is_single_dataset = is_single_dataset_value |
| 630 |
), |
|
| 631 | ! |
conditionalPanel( |
| 632 | ! |
condition = paste0("input['", ns("type"), "'] == 'Univariate'"),
|
| 633 | ! |
checkboxInput( |
| 634 | ! |
ns("interactions"),
|
| 635 | ! |
"Interaction terms" |
| 636 |
) |
|
| 637 |
), |
|
| 638 | ! |
uiOutput(ns("interaction_input")),
|
| 639 | ! |
teal.transform::data_extract_ui( |
| 640 | ! |
id = ns("strata_var"),
|
| 641 | ! |
label = "Stratify by", |
| 642 | ! |
data_extract_spec = a$strata_var, |
| 643 | ! |
is_single_dataset = is_single_dataset_value |
| 644 |
), |
|
| 645 | ! |
teal.widgets::panel_group( |
| 646 | ! |
teal.widgets::panel_item( |
| 647 | ! |
"Additional table settings", |
| 648 | ! |
conditionalPanel( |
| 649 | ! |
condition = paste0("input['", ns("strata_var"), "'] != ''"),
|
| 650 | ! |
radioButtons( |
| 651 | ! |
ns("pval_method"),
|
| 652 | ! |
label = tags$p( |
| 653 | ! |
"p-value method for", |
| 654 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 655 | ! |
"(Hazard Ratio)" |
| 656 |
), |
|
| 657 | ! |
choices = c("wald", "likelihood"),
|
| 658 | ! |
selected = "wald" |
| 659 |
) |
|
| 660 |
), |
|
| 661 | ! |
radioButtons( |
| 662 | ! |
ns("ties"),
|
| 663 | ! |
label = tags$p( |
| 664 | ! |
"Ties for ", |
| 665 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 666 | ! |
" (Hazard Ratio)", |
| 667 | ! |
sep = "" |
| 668 |
), |
|
| 669 | ! |
choices = c("exact", "breslow", "efron"),
|
| 670 | ! |
selected = "exact" |
| 671 |
), |
|
| 672 | ! |
teal.widgets::optionalSelectInput( |
| 673 | ! |
inputId = ns("conf_level"),
|
| 674 | ! |
label = tags$p( |
| 675 | ! |
"Confidence level for ", |
| 676 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 677 | ! |
" (Hazard Ratio)", |
| 678 | ! |
sep = "" |
| 679 |
), |
|
| 680 | ! |
a$conf_level$choices, |
| 681 | ! |
a$conf_level$selected, |
| 682 | ! |
multiple = FALSE, |
| 683 | ! |
fixed = a$conf_level$fixed |
| 684 |
) |
|
| 685 |
) |
|
| 686 |
) |
|
| 687 |
), |
|
| 688 | ! |
forms = tagList( |
| 689 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 690 |
), |
|
| 691 | ! |
pre_output = a$pre_output, |
| 692 | ! |
post_output = a$post_output |
| 693 |
) |
|
| 694 |
} |
|
| 695 | ||
| 696 |
#' @keywords internal |
|
| 697 |
srv_t_coxreg <- function(id, |
|
| 698 |
data, |
|
| 699 |
reporter, |
|
| 700 |
filter_panel_api, |
|
| 701 |
dataname, |
|
| 702 |
parentname, |
|
| 703 |
arm_var, |
|
| 704 |
paramcd, |
|
| 705 |
strata_var, |
|
| 706 |
aval_var, |
|
| 707 |
cnsr_var, |
|
| 708 |
cov_var, |
|
| 709 |
arm_ref_comp, |
|
| 710 |
label, |
|
| 711 |
na_level, |
|
| 712 |
basic_table_args) {
|
|
| 713 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 714 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 715 | ! |
checkmate::assert_class(data, "reactive") |
| 716 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 717 | ||
| 718 | ! |
moduleServer(id, function(input, output, session) {
|
| 719 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 720 |
# Observer to update reference and comparison arm input options. |
|
| 721 | ! |
iv_arm_ref <- arm_ref_comp_observer( |
| 722 | ! |
session, |
| 723 | ! |
input, |
| 724 | ! |
output, |
| 725 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 726 | ! |
data = reactive(data()[[parentname]]), |
| 727 | ! |
arm_ref_comp = arm_ref_comp, |
| 728 | ! |
module = "tm_t_coxreg" |
| 729 |
) |
|
| 730 | ||
| 731 | ! |
use_interactions <- reactive({
|
| 732 | ! |
input$type == "Univariate" && isTRUE(input$interactions) |
| 733 |
}) |
|
| 734 | ||
| 735 | ! |
overlap_rule <- function(other_var, var_name) {
|
| 736 | ! |
function(value) {
|
| 737 | ! |
if (length(intersect(value, selector_list()[[other_var]]()$select)) > 0) {
|
| 738 | ! |
sprintf("`%s` and `%s` variables should not overlap", var_name[1], var_name[2])
|
| 739 |
} |
|
| 740 |
} |
|
| 741 |
} |
|
| 742 | ||
| 743 | ! |
select_validation_rule <- list( |
| 744 | ! |
aval_var = shinyvalidate::sv_required("An analysis variable is required"),
|
| 745 | ! |
cnsr_var = shinyvalidate::sv_required("A censor variable is required"),
|
| 746 | ! |
arm_var = shinyvalidate::compose_rules( |
| 747 | ! |
shinyvalidate::sv_required("A treatment variable is required"),
|
| 748 | ! |
overlap_rule("strata_var", c("Treatment", "Strata")),
|
| 749 | ! |
overlap_rule("cov_var", c("Treatment", "Covariate"))
|
| 750 |
), |
|
| 751 | ! |
strata_var = shinyvalidate::compose_rules( |
| 752 | ! |
overlap_rule("arm_var", c("Treatment", "Strata")),
|
| 753 | ! |
overlap_rule("cov_var", c("Covariate", "Strata"))
|
| 754 |
), |
|
| 755 | ! |
cov_var = shinyvalidate::compose_rules( |
| 756 | ! |
overlap_rule("arm_var", c("Treatment", "Covariate")),
|
| 757 | ! |
overlap_rule("strata_var", c("Covariate", "Strata")),
|
| 758 | ! |
~ if (use_interactions() && length(.) == 0) {
|
| 759 | ! |
"If interactions are selected at least one covariate should be specified." |
| 760 |
} |
|
| 761 |
) |
|
| 762 |
) |
|
| 763 | ||
| 764 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 765 | ! |
data_extract = list( |
| 766 | ! |
arm_var = arm_var, |
| 767 | ! |
paramcd = paramcd, |
| 768 | ! |
strata_var = strata_var, |
| 769 | ! |
aval_var = aval_var, |
| 770 | ! |
cnsr_var = cnsr_var, |
| 771 | ! |
cov_var = cov_var |
| 772 |
), |
|
| 773 | ! |
datasets = data, |
| 774 | ! |
select_validation_rule = select_validation_rule, |
| 775 | ! |
filter_validation_rule = list( |
| 776 | ! |
paramcd = shinyvalidate::sv_required("An endpoint is required")
|
| 777 |
) |
|
| 778 |
) |
|
| 779 | ||
| 780 | ||
| 781 | ! |
numeric_level_validation <- function(val) {
|
| 782 |
# need to explicitly evaluate 'val' here to ensure |
|
| 783 |
# the correct label is shown - if this is not done |
|
| 784 |
# then the last value of "val" is the label for all cases |
|
| 785 | ! |
v <- val |
| 786 | ! |
~ if (anyNA(as_numeric_from_comma_sep_str(.))) {
|
| 787 | ! |
paste("Numeric interaction level(s) should be specified for", v)
|
| 788 |
} |
|
| 789 |
} |
|
| 790 | ||
| 791 | ||
| 792 | ! |
iv_r <- reactive({
|
| 793 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 794 | ! |
iv$add_validator(iv_arm_ref) |
| 795 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level"))
|
| 796 | ! |
iv$add_rule( |
| 797 | ! |
"conf_level", |
| 798 | ! |
shinyvalidate::sv_between(0, 1, message_fmt = "Confidence level must be between 0 and 1") |
| 799 |
) |
|
| 800 | ! |
iv$add_rule("pval_method", ~ if (length(selector_list()$strata_var()$select) > 0 && . != "wald") {
|
| 801 | ! |
"Only Wald tests are supported for models with strata." |
| 802 |
}) |
|
| 803 |
# add rules for interaction_var text inputs |
|
| 804 | ||
| 805 | ! |
for (val in interaction_var_r()) {
|
| 806 | ! |
iv$add_rule( |
| 807 | ! |
paste0("interact_", val),
|
| 808 | ! |
shinyvalidate::sv_required(paste("Interaction level(s) should be specified for", val))
|
| 809 |
) |
|
| 810 | ! |
iv$add_rule( |
| 811 | ! |
paste0("interact_", val), numeric_level_validation(val)
|
| 812 |
) |
|
| 813 |
} |
|
| 814 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 815 |
}) |
|
| 816 | ||
| 817 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 818 | ! |
datasets = data, |
| 819 | ! |
selector_list = selector_list, |
| 820 | ! |
merge_function = "dplyr::inner_join" |
| 821 |
) |
|
| 822 | ||
| 823 | ! |
anl_q <- reactive({
|
| 824 | ! |
data() %>% |
| 825 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 826 |
}) |
|
| 827 | ||
| 828 | ! |
merged <- list( |
| 829 | ! |
anl_input_r = anl_inputs, |
| 830 | ! |
anl_q = anl_q |
| 831 |
) |
|
| 832 | ||
| 833 |
## render conditional strata levels input UI ---- |
|
| 834 | ! |
open_textinput <- function(x, dataset) {
|
| 835 |
# For every numeric covariate, the numeric level for the Hazard Ration |
|
| 836 |
# estimation is proposed only if the covariate is included in the model: |
|
| 837 |
# for this purpose, a function and a UI-rendered output. |
|
| 838 | ! |
textInput( |
| 839 | ! |
session$ns(paste0("interact_", x)),
|
| 840 | ! |
label = paste("Hazard Ratios for", x, "at (comma delimited):"),
|
| 841 | ! |
value = as.character(stats::median(dataset[[x]])) |
| 842 |
) |
|
| 843 |
} |
|
| 844 | ||
| 845 | ! |
interaction_var_r <- reactive({
|
| 846 |
# exclude cases when increments are not necessary and |
|
| 847 |
# finally accessing the UI-rendering function defined above. |
|
| 848 | ! |
if (use_interactions()) {
|
| 849 | ! |
input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) |
| 850 | ! |
dataset <- merged$anl_q()[[dataname]] |
| 851 | ! |
cov_is_numeric <- vapply(dataset[input_cov_var], is.numeric, logical(1)) |
| 852 | ! |
input_cov_var[cov_is_numeric] |
| 853 |
} else {
|
|
| 854 | ! |
NULL |
| 855 |
} |
|
| 856 |
}) |
|
| 857 | ||
| 858 | ! |
output$interaction_input <- renderUI({
|
| 859 | ! |
if (length(interaction_var_r()) > 0) {
|
| 860 | ! |
lapply(interaction_var_r(), open_textinput, dataset = merged$anl_q()[[dataname]]) |
| 861 |
} |
|
| 862 |
}) |
|
| 863 | ||
| 864 |
## Prepare the call evaluation environment ---- |
|
| 865 | ! |
validate_checks <- reactive({
|
| 866 | ! |
teal::validate_inputs(iv_r()) |
| 867 | ||
| 868 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 869 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 870 | ||
| 871 | ! |
input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) |
| 872 | ! |
input_strata_var <- as.vector(merged$anl_input_r()$columns_source$strata_var) |
| 873 | ! |
input_aval_var <- as.vector(merged$anl_input_r()$columns_source$aval_var) |
| 874 | ! |
input_cnsr_var <- as.vector(merged$anl_input_r()$columns_source$cnsr_var) |
| 875 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 876 | ! |
input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) |
| 877 | ||
| 878 | ! |
cov_is_numeric <- vapply(anl_filtered[input_cov_var], is.numeric, logical(1)) |
| 879 | ! |
interaction_var <- input_cov_var[cov_is_numeric] |
| 880 | ||
| 881 |
# validate inputs |
|
| 882 | ! |
validate_args <- list( |
| 883 | ! |
adsl = adsl_filtered, |
| 884 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var, input_strata_var),
|
| 885 | ! |
anl = anl_filtered, |
| 886 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_aval_var, input_cnsr_var),
|
| 887 | ! |
arm_var = input_arm_var, |
| 888 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 889 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 890 | ! |
min_nrow = 4 |
| 891 |
) |
|
| 892 | ||
| 893 |
# validate arm levels |
|
| 894 | ! |
if (length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) == 1) {
|
| 895 | ! |
validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) |
| 896 |
} |
|
| 897 | ||
| 898 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 899 | ||
| 900 | ! |
arm_n <- base::table(anl_filtered[[input_arm_var]]) |
| 901 | ! |
anl_arm_n <- if (input$combine_comp_arms) {
|
| 902 | ! |
c(sum(arm_n[unlist(input$buckets$Ref)]), sum(arm_n[unlist(input$buckets$Comp)])) |
| 903 |
} else {
|
|
| 904 | ! |
c(sum(arm_n[unlist(input$buckets$Ref)]), arm_n[unlist(input$buckets$Comp)]) |
| 905 |
} |
|
| 906 | ! |
validate(shiny::need( |
| 907 | ! |
all(anl_arm_n >= 2), |
| 908 | ! |
"Each treatment group should have at least 2 records." |
| 909 |
)) |
|
| 910 | ||
| 911 |
# validate covariate has at least two levels |
|
| 912 | ! |
validate( |
| 913 | ! |
need( |
| 914 | ! |
all(vapply(anl_filtered[input_cov_var], FUN = function(x) {
|
| 915 | ! |
length(unique(x)) > 1 |
| 916 | ! |
}, logical(1))), |
| 917 | ! |
"All covariates needs to have at least two levels" |
| 918 |
) |
|
| 919 |
) |
|
| 920 | ||
| 921 | ! |
NULL |
| 922 |
}) |
|
| 923 | ||
| 924 | ! |
at <- reactive({
|
| 925 | ! |
input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) |
| 926 | ! |
cov_is_numeric <- vapply(merged$anl_q()[[dataname]][input_cov_var], is.numeric, logical(1)) |
| 927 | ! |
interaction_var <- input_cov_var[cov_is_numeric] |
| 928 | ! |
if (length(interaction_var) > 0 && length(input_cov_var) > 0) {
|
| 929 | ! |
res <- lapply( |
| 930 | ! |
interaction_var, |
| 931 | ! |
function(x) {
|
| 932 | ! |
cov <- input[[paste0("interact_", x)]]
|
| 933 | ! |
if (!is.null(cov)) {
|
| 934 | ! |
as_numeric_from_comma_sep_str(cov) |
| 935 |
} |
|
| 936 |
} |
|
| 937 |
) |
|
| 938 | ! |
stats::setNames(res, interaction_var) |
| 939 |
} |
|
| 940 |
}) |
|
| 941 | ||
| 942 | ||
| 943 | ! |
call_template <- function(comp_arm, anl, paramcd, multivariate, basic_table_args = NULL) {
|
| 944 | ! |
strata_var <- as.vector(anl$columns_source$strata_var) |
| 945 | ! |
strata_var <- if (length(strata_var) != 0) strata_var else NULL |
| 946 | ! |
cov_var <- as.vector(anl$columns_source$cov_var) |
| 947 | ! |
cov_var <- if (length(cov_var) > 0) cov_var else NULL |
| 948 | ||
| 949 | ! |
at <- if (use_interactions()) at() else list() |
| 950 | ! |
arm_var <- as.vector(anl$columns_source$arm_var) |
| 951 | ! |
cnsr_var <- as.vector(anl$columns_source$cnsr_var) |
| 952 | ! |
aval_var <- as.vector(anl$columns_source$aval_var) |
| 953 | ! |
ref_arm <- unlist(input$buckets$Ref) |
| 954 | ! |
combine_comp_arms <- input$combine_comp_arms |
| 955 | ! |
control <- control_coxreg( |
| 956 | ! |
pval_method = input$pval_method, |
| 957 | ! |
ties = input$ties, |
| 958 | ! |
conf_level = as.numeric(input$conf_level), |
| 959 | ! |
interaction = `if`(!use_interactions(), FALSE, input$interactions) |
| 960 |
) |
|
| 961 | ||
| 962 | ! |
if (multivariate) {
|
| 963 | ! |
template_coxreg_m( |
| 964 | ! |
dataname = "ANL", |
| 965 | ! |
cov_var = cov_var, |
| 966 | ! |
at = at, |
| 967 | ! |
arm_var = arm_var, |
| 968 | ! |
cnsr_var = cnsr_var, |
| 969 | ! |
aval_var = aval_var, |
| 970 | ! |
ref_arm = ref_arm, |
| 971 | ! |
comp_arm = comp_arm, |
| 972 | ! |
paramcd = paramcd, |
| 973 | ! |
strata_var = strata_var, |
| 974 | ! |
combine_comp_arms = combine_comp_arms, |
| 975 | ! |
control = control, |
| 976 | ! |
na_level = na_level, |
| 977 | ! |
basic_table_args = basic_table_args |
| 978 |
) |
|
| 979 |
} else {
|
|
| 980 | ! |
template_coxreg_u( |
| 981 | ! |
dataname = "ANL", |
| 982 | ! |
cov_var = cov_var, |
| 983 | ! |
at = at, |
| 984 | ! |
arm_var = arm_var, |
| 985 | ! |
cnsr_var = cnsr_var, |
| 986 | ! |
aval_var = aval_var, |
| 987 | ! |
ref_arm = ref_arm, |
| 988 | ! |
comp_arm = comp_arm, |
| 989 | ! |
paramcd = paramcd, |
| 990 | ! |
strata_var = strata_var, |
| 991 | ! |
combine_comp_arms = combine_comp_arms, |
| 992 | ! |
control = control, |
| 993 | ! |
na_level = na_level, |
| 994 | ! |
append = TRUE, |
| 995 | ! |
basic_table_args = basic_table_args |
| 996 |
) |
|
| 997 |
} |
|
| 998 |
} |
|
| 999 | ||
| 1000 |
## generate table call with template and render table ---- |
|
| 1001 | ! |
all_q <- reactive({
|
| 1002 | ! |
validate_checks() |
| 1003 | ||
| 1004 | ! |
ANL <- merged$anl_q()[["ANL"]] |
| 1005 | ! |
paramcd <- as.character(unique(ANL[[unlist(paramcd$filter)["vars_selected"]]])) |
| 1006 | ! |
multivariate <- input$type == "Multivariate" |
| 1007 | ! |
strata_var <- as.vector(merged$anl_input_r()$columns_source$strata_var) |
| 1008 | ||
| 1009 | ! |
if (input$type == "Multivariate") {
|
| 1010 | ! |
main_title <- paste("Multi-Variable Cox Regression for", paramcd)
|
| 1011 | ! |
subtitle <- ifelse(length(strata_var) == 0, "", paste("Stratified by", paste(strata_var, collapse = " and ")))
|
| 1012 | ! |
all_basic_table_args <- teal.widgets::resolve_basic_table_args( |
| 1013 | ! |
user_table = basic_table_args, |
| 1014 | ! |
module_table = teal.widgets::basic_table_args( |
| 1015 | ! |
title = main_title, |
| 1016 | ! |
subtitles = subtitle |
| 1017 |
) |
|
| 1018 |
) |
|
| 1019 | ! |
expr <- call_template( |
| 1020 | ! |
unlist(input$buckets$Comp), merged$anl_input_r(), |
| 1021 | ! |
paramcd, multivariate, all_basic_table_args |
| 1022 |
) |
|
| 1023 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(expr)) |
| 1024 |
} else {
|
|
| 1025 | ! |
main_title <- paste("Cox Regression for", paramcd)
|
| 1026 | ! |
subtitle <- ifelse(length(strata_var) == 0, "", paste("Stratified by", paste(strata_var, collapse = " and ")))
|
| 1027 | ! |
all_basic_table_args <- teal.widgets::resolve_basic_table_args( |
| 1028 | ! |
user_table = basic_table_args, |
| 1029 | ! |
module_table = teal.widgets::basic_table_args( |
| 1030 | ! |
title = main_title, |
| 1031 | ! |
subtitles = subtitle |
| 1032 |
) |
|
| 1033 |
) |
|
| 1034 | ||
| 1035 | ! |
merged$anl_q() %>% |
| 1036 | ! |
teal.code::eval_code(quote(result <- list())) %>% |
| 1037 | ! |
teal.code::eval_code( |
| 1038 | ! |
as.expression(unlist(lapply( |
| 1039 | ! |
unlist(input$buckets$Comp), |
| 1040 | ! |
function(x) {
|
| 1041 | ! |
call_template(x, merged$anl_input_r(), paramcd, multivariate, all_basic_table_args) |
| 1042 |
} |
|
| 1043 |
))) |
|
| 1044 |
) %>% |
|
| 1045 | ! |
teal.code::eval_code( |
| 1046 | ! |
substitute( |
| 1047 | ! |
expr = {
|
| 1048 | ! |
result <- lapply(result, function(x) {
|
| 1049 | ! |
rtables::col_info(x) <- rtables::col_info(result[[1]]) |
| 1050 | ! |
x |
| 1051 |
}) |
|
| 1052 | ! |
result <- rtables::rbindl_rtables(result, check_headers = TRUE) |
| 1053 | ! |
rtables::main_title(result) <- title |
| 1054 | ! |
rtables::main_footer(result) <- c( |
| 1055 | ! |
paste("p-value method for Coxph (Hazard Ratio):", control$pval_method),
|
| 1056 | ! |
paste("Ties for Coxph (Hazard Ratio):", control$ties)
|
| 1057 |
) |
|
| 1058 | ! |
rtables::prov_footer(result) <- p_footer |
| 1059 | ! |
rtables::subtitles(result) <- subtitle |
| 1060 | ! |
result |
| 1061 |
}, |
|
| 1062 | ! |
env = list( |
| 1063 | ! |
title = all_basic_table_args$title, |
| 1064 | ! |
p_footer = `if`(is.null(all_basic_table_args$prov_footer), "", all_basic_table_args$prov_footer), |
| 1065 | ! |
subtitle = `if`(is.null(all_basic_table_args$subtitles), "", all_basic_table_args$subtitles) |
| 1066 |
) |
|
| 1067 |
) |
|
| 1068 |
) |
|
| 1069 |
} |
|
| 1070 |
}) |
|
| 1071 | ||
| 1072 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 1073 | ||
| 1074 | ! |
teal.widgets::table_with_settings_srv( |
| 1075 | ! |
id = "table", |
| 1076 | ! |
table_r = table_r |
| 1077 |
) |
|
| 1078 | ||
| 1079 | ! |
teal.widgets::verbatim_popup_srv( |
| 1080 | ! |
id = "rcode", |
| 1081 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 1082 | ! |
title = "R Code for the Current (Multi-Variable) Cox proportional hazard regression model" |
| 1083 |
) |
|
| 1084 | ||
| 1085 |
### REPORTER |
|
| 1086 | ! |
if (with_reporter) {
|
| 1087 | ! |
card_fun <- function(comment, label) {
|
| 1088 | ! |
card <- teal::report_card_template( |
| 1089 | ! |
title = "Cox Regression Table", |
| 1090 | ! |
label = label, |
| 1091 | ! |
with_filter = with_filter, |
| 1092 | ! |
filter_panel_api = filter_panel_api |
| 1093 |
) |
|
| 1094 | ! |
card$append_text("Table", "header3")
|
| 1095 | ! |
card$append_table(table_r()) |
| 1096 | ! |
if (!comment == "") {
|
| 1097 | ! |
card$append_text("Comment", "header3")
|
| 1098 | ! |
card$append_text(comment) |
| 1099 |
} |
|
| 1100 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 1101 | ! |
card |
| 1102 |
} |
|
| 1103 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1104 |
} |
|
| 1105 |
### |
|
| 1106 |
}) |
|
| 1107 |
} |
| 1 |
#' Template: Events by Term |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table of events by term. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param sort_freq_col (`character`)\cr column to sort by frequency on if `sort_criteria` is set to `freq_desc`. |
|
| 7 |
#' @param incl_overall_sum (`flag`)\cr whether two rows which summarize the overall number of adverse events |
|
| 8 |
#' should be included at the top of the table. |
|
| 9 |
#' |
|
| 10 |
#' @inherit template_arguments return |
|
| 11 |
#' |
|
| 12 |
#' @seealso [tm_t_events()] |
|
| 13 |
#' |
|
| 14 |
#' @keywords internal |
|
| 15 |
template_events <- function(dataname, |
|
| 16 |
parentname, |
|
| 17 |
arm_var, |
|
| 18 |
hlt, |
|
| 19 |
llt, |
|
| 20 |
label_hlt = NULL, |
|
| 21 |
label_llt = NULL, |
|
| 22 |
add_total = TRUE, |
|
| 23 |
total_label = default_total_label(), |
|
| 24 |
na_level = default_na_str(), |
|
| 25 |
event_type = "event", |
|
| 26 |
sort_criteria = c("freq_desc", "alpha"),
|
|
| 27 |
sort_freq_col = total_label, |
|
| 28 |
prune_freq = 0, |
|
| 29 |
prune_diff = 0, |
|
| 30 |
drop_arm_levels = TRUE, |
|
| 31 |
incl_overall_sum = TRUE, |
|
| 32 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 33 | 6x |
checkmate::assert_string(dataname) |
| 34 | 6x |
checkmate::assert_string(parentname) |
| 35 | 6x |
checkmate::assert_character(arm_var, min.len = 1, max.len = 2) |
| 36 | 6x |
checkmate::assert_string(hlt, null.ok = TRUE) |
| 37 | 6x |
checkmate::assert_string(llt, null.ok = TRUE) |
| 38 | 6x |
checkmate::assert_string(label_hlt, null.ok = TRUE) |
| 39 | 6x |
checkmate::assert_string(label_llt, null.ok = TRUE) |
| 40 | 6x |
checkmate::assert_character(c(llt, hlt)) |
| 41 | 6x |
checkmate::assert_flag(add_total) |
| 42 | 6x |
checkmate::assert_string(total_label) |
| 43 | 6x |
checkmate::assert_string(na_level) |
| 44 | 6x |
checkmate::assert_string(event_type) |
| 45 | 6x |
checkmate::assert_flag(drop_arm_levels) |
| 46 | 6x |
checkmate::assert_scalar(prune_freq) |
| 47 | 6x |
checkmate::assert_scalar(prune_diff) |
| 48 | ||
| 49 | 6x |
sort_criteria <- match.arg(sort_criteria) |
| 50 | ||
| 51 | 6x |
y <- list() |
| 52 | ||
| 53 |
# Start data steps. |
|
| 54 | 6x |
data_list <- list() |
| 55 | ||
| 56 | 6x |
data_list <- add_expr( |
| 57 | 6x |
data_list, |
| 58 | 6x |
substitute( |
| 59 | 6x |
expr = anl <- df, |
| 60 | 6x |
env = list(df = as.name(dataname)) |
| 61 |
) |
|
| 62 |
) |
|
| 63 | ||
| 64 | 6x |
data_list <- add_expr( |
| 65 | 6x |
data_list, |
| 66 | 6x |
prepare_arm_levels( |
| 67 | 6x |
dataname = "anl", |
| 68 | 6x |
parentname = parentname, |
| 69 | 6x |
arm_var = arm_var[[1]], |
| 70 | 6x |
drop_arm_levels = drop_arm_levels |
| 71 |
) |
|
| 72 |
) |
|
| 73 | 6x |
if (length(arm_var) == 2) {
|
| 74 | 2x |
data_list <- add_expr( |
| 75 | 2x |
data_list, |
| 76 | 2x |
prepare_arm_levels( |
| 77 | 2x |
dataname = "anl", |
| 78 | 2x |
parentname = parentname, |
| 79 | 2x |
arm_var = arm_var[[2]], |
| 80 | 2x |
drop_arm_levels = drop_arm_levels |
| 81 |
) |
|
| 82 |
) |
|
| 83 |
} |
|
| 84 | ||
| 85 | 6x |
data_list <- add_expr( |
| 86 | 6x |
data_list, |
| 87 | 6x |
substitute( |
| 88 | 6x |
expr = parentname <- df_explicit_na(parentname, na_level = na_lvl), |
| 89 | 6x |
env = list(parentname = as.name(parentname), na_lvl = na_level) |
| 90 |
) |
|
| 91 |
) |
|
| 92 | ||
| 93 | 6x |
if (sort_criteria == "alpha") {
|
| 94 | 1x |
if (!is.null(hlt)) {
|
| 95 | 1x |
data_list <- add_expr( |
| 96 | 1x |
data_list, |
| 97 | 1x |
substitute( |
| 98 | 1x |
expr = anl[[hlt]] <- as.character(anl[[hlt]]), |
| 99 | 1x |
env = list(hlt = hlt) |
| 100 |
) |
|
| 101 |
) |
|
| 102 |
} |
|
| 103 | ||
| 104 | 1x |
if (!is.null(llt)) {
|
| 105 | 1x |
data_list <- add_expr( |
| 106 | 1x |
data_list, |
| 107 | 1x |
substitute( |
| 108 | 1x |
expr = anl[[llt]] <- as.character(anl[[llt]]), |
| 109 | 1x |
env = list(llt = llt) |
| 110 |
) |
|
| 111 |
) |
|
| 112 |
} |
|
| 113 |
} |
|
| 114 | ||
| 115 | 6x |
term_vars <- c(hlt, llt) |
| 116 | ||
| 117 | 6x |
data_list <- add_expr( |
| 118 | 6x |
data_list, |
| 119 | 6x |
substitute( |
| 120 | 6x |
expr = anl <- anl %>% |
| 121 | 6x |
df_explicit_na(omit_columns = setdiff(names(anl), term_vars)), |
| 122 | 6x |
env = list( |
| 123 | 6x |
term_vars = term_vars |
| 124 |
) |
|
| 125 |
) |
|
| 126 |
) |
|
| 127 | 6x |
y$data <- bracket_expr(data_list) |
| 128 | ||
| 129 |
# Start layout steps. |
|
| 130 | 6x |
layout_list <- list() |
| 131 | ||
| 132 | 6x |
basic_title <- if (is.null(hlt) && !is.null(llt)) {
|
| 133 | 1x |
paste0("Event Summary by Term : ", label_llt)
|
| 134 | 6x |
} else if (!is.null(hlt) && is.null(llt)) {
|
| 135 | ! |
paste0("Event Summary by Term : ", label_hlt)
|
| 136 | 6x |
} else if (!is.null(hlt) && !is.null(llt)) {
|
| 137 | 5x |
paste0("Event Summary by Term : ", label_hlt, " and ", label_llt)
|
| 138 |
} else {
|
|
| 139 | ! |
"Event Summary by Term" |
| 140 |
} |
|
| 141 | ||
| 142 | 6x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 143 | 6x |
teal.widgets::resolve_basic_table_args( |
| 144 | 6x |
user_table = basic_table_args, |
| 145 | 6x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE, title = basic_title) |
| 146 |
) |
|
| 147 |
) |
|
| 148 | ||
| 149 | 6x |
layout_list <- add_expr(layout_list, parsed_basic_table_args) |
| 150 | 6x |
layout_list <- add_expr( |
| 151 | 6x |
layout_list, |
| 152 | 6x |
substitute( |
| 153 | 6x |
expr = rtables::split_cols_by(var = arm_var), |
| 154 | 6x |
env = list(arm_var = arm_var[[1]]) |
| 155 |
) |
|
| 156 |
) |
|
| 157 | 6x |
if (length(arm_var) == 2) {
|
| 158 | 2x |
layout_list <- add_expr( |
| 159 | 2x |
layout_list, |
| 160 | 2x |
if (drop_arm_levels) {
|
| 161 | 2x |
substitute( |
| 162 | 2x |
expr = rtables::split_cols_by(nested_col, split_fun = drop_split_levels), |
| 163 | 2x |
env = list(nested_col = arm_var[[2]]) |
| 164 |
) |
|
| 165 |
} else {
|
|
| 166 | ! |
substitute( |
| 167 | ! |
expr = rtables::split_cols_by(nested_col), |
| 168 | ! |
env = list(nested_col = arm_var[[2]]) |
| 169 |
) |
|
| 170 |
} |
|
| 171 |
) |
|
| 172 |
} |
|
| 173 | ||
| 174 | 6x |
if (add_total) {
|
| 175 | 5x |
layout_list <- add_expr( |
| 176 | 5x |
layout_list, |
| 177 | 5x |
substitute( |
| 178 | 5x |
expr = rtables::add_overall_col(label = total_label), |
| 179 | 5x |
env = list(total_label = total_label) |
| 180 |
) |
|
| 181 |
) |
|
| 182 |
} |
|
| 183 | ||
| 184 | 6x |
unique_label <- paste0("Total number of patients with at least one ", event_type)
|
| 185 | 6x |
nonunique_label <- paste0("Overall total number of ", event_type, "s")
|
| 186 | ||
| 187 | 6x |
if (incl_overall_sum) {
|
| 188 | 6x |
layout_list <- add_expr( |
| 189 | 6x |
layout_list, |
| 190 | 6x |
substitute( |
| 191 | 6x |
summarize_num_patients( |
| 192 | 6x |
var = "USUBJID", |
| 193 | 6x |
.stats = c("unique", "nonunique"),
|
| 194 | 6x |
.labels = c( |
| 195 | 6x |
unique = unique_label, |
| 196 | 6x |
nonunique = nonunique_label |
| 197 |
), |
|
| 198 | 6x |
na_str = na_str |
| 199 |
), |
|
| 200 | 6x |
env = list(unique_label = unique_label, nonunique_label = nonunique_label, na_str = na_level) |
| 201 |
) |
|
| 202 |
) |
|
| 203 |
} |
|
| 204 | ||
| 205 | ||
| 206 | 6x |
one_term <- is.null(hlt) || is.null(llt) |
| 207 | ||
| 208 | 6x |
if (one_term) {
|
| 209 | 1x |
term_var <- ifelse(is.null(hlt), llt, hlt) |
| 210 | ||
| 211 | 1x |
layout_list <- add_expr( |
| 212 | 1x |
layout_list, |
| 213 | 1x |
substitute( |
| 214 | 1x |
expr = count_occurrences(vars = term_var, .indent_mods = -1L) %>% |
| 215 | 1x |
append_varlabels(dataname, term_var), |
| 216 | 1x |
env = list( |
| 217 | 1x |
term_var = term_var, |
| 218 | 1x |
dataname = as.name(dataname) |
| 219 |
) |
|
| 220 |
) |
|
| 221 |
) |
|
| 222 |
} else {
|
|
| 223 |
# Case when both hlt and llt are used. |
|
| 224 | ||
| 225 | 5x |
y$layout_prep <- quote(split_fun <- drop_split_levels) |
| 226 | ||
| 227 | 5x |
layout_list <- add_expr( |
| 228 | 5x |
layout_list, |
| 229 | 5x |
substitute( |
| 230 | 5x |
expr = rtables::split_rows_by( |
| 231 | 5x |
hlt, |
| 232 | 5x |
child_labels = "visible", |
| 233 | 5x |
nested = FALSE, |
| 234 | 5x |
indent_mod = -1L, |
| 235 | 5x |
split_fun = split_fun, |
| 236 | 5x |
label_pos = "topleft", |
| 237 | 5x |
split_label = teal.data::col_labels(dataname[hlt]) |
| 238 |
) %>% |
|
| 239 | 5x |
summarize_num_patients( |
| 240 | 5x |
var = "USUBJID", |
| 241 | 5x |
.stats = c("unique", "nonunique"),
|
| 242 | 5x |
.labels = c( |
| 243 | 5x |
unique = unique_label, |
| 244 | 5x |
nonunique = nonunique_label |
| 245 |
), |
|
| 246 | 5x |
na_str = na_str |
| 247 |
) %>% |
|
| 248 | 5x |
count_occurrences(vars = llt, .indent_mods = c(count_fraction = 1L)) %>% |
| 249 | 5x |
append_varlabels(dataname, llt, indent = 1L), |
| 250 | 5x |
env = list( |
| 251 | 5x |
dataname = as.name(dataname), |
| 252 | 5x |
hlt = hlt, |
| 253 | 5x |
llt = llt, |
| 254 | 5x |
unique_label = unique_label, |
| 255 | 5x |
nonunique_label = nonunique_label, |
| 256 | 5x |
na_str = na_level |
| 257 |
) |
|
| 258 |
) |
|
| 259 |
) |
|
| 260 |
} |
|
| 261 | ||
| 262 | 6x |
y$layout <- substitute( |
| 263 | 6x |
expr = lyt <- layout_pipe, |
| 264 | 6x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 265 |
) |
|
| 266 | ||
| 267 |
# Full table. |
|
| 268 | 6x |
y$table <- substitute( |
| 269 | 6x |
expr = result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent), |
| 270 | 6x |
env = list(parent = as.name(parentname)) |
| 271 |
) |
|
| 272 | ||
| 273 |
# Start pruning table. |
|
| 274 | 6x |
prune_list <- list() |
| 275 | 6x |
prune_list <- add_expr( |
| 276 | 6x |
prune_list, |
| 277 | 6x |
quote( |
| 278 | 6x |
pruned_result <- result %>% rtables::prune_table() |
| 279 |
) |
|
| 280 |
) |
|
| 281 | ||
| 282 | 6x |
if (prune_freq > 0 || prune_diff > 0) {
|
| 283 |
# Do not use "All Patients" column for pruning conditions. |
|
| 284 | 2x |
prune_list <- add_expr( |
| 285 | 2x |
prune_list, |
| 286 | 2x |
substitute( |
| 287 | 2x |
expr = col_indices <- 1:(ncol(result) - add_total), |
| 288 | 2x |
env = list(add_total = add_total) |
| 289 |
) |
|
| 290 |
) |
|
| 291 | ||
| 292 | 2x |
if (prune_freq > 0 && prune_diff == 0) {
|
| 293 | ! |
prune_list <- add_expr( |
| 294 | ! |
prune_list, |
| 295 | ! |
substitute( |
| 296 | ! |
expr = row_condition <- has_fraction_in_any_col(atleast = prune_freq, col_indices = col_indices), |
| 297 | ! |
env = list(prune_freq = prune_freq) |
| 298 |
) |
|
| 299 |
) |
|
| 300 | 2x |
} else if (prune_freq == 0 && prune_diff > 0) {
|
| 301 | ! |
prune_list <- add_expr( |
| 302 | ! |
prune_list, |
| 303 | ! |
substitute( |
| 304 | ! |
expr = row_condition <- has_fractions_difference(atleast = prune_diff, col_indices = col_indices), |
| 305 | ! |
env = list(prune_diff = prune_diff) |
| 306 |
) |
|
| 307 |
) |
|
| 308 | 2x |
} else if (prune_freq > 0 && prune_diff > 0) {
|
| 309 | 2x |
prune_list <- add_expr( |
| 310 | 2x |
prune_list, |
| 311 | 2x |
substitute( |
| 312 | 2x |
expr = row_condition <- has_fraction_in_any_col(atleast = prune_freq, col_indices = col_indices) & |
| 313 | 2x |
has_fractions_difference(atleast = prune_diff, col_indices = col_indices), |
| 314 | 2x |
env = list(prune_freq = prune_freq, prune_diff = prune_diff) |
| 315 |
) |
|
| 316 |
) |
|
| 317 |
} |
|
| 318 | ||
| 319 |
# Apply pruning conditions. |
|
| 320 | 2x |
prune_list <- add_expr( |
| 321 | 2x |
prune_list, |
| 322 | 2x |
substitute( |
| 323 | 2x |
expr = pruned_result <- pruned_result %>% rtables::prune_table(keep_rows(row_condition)) |
| 324 |
) |
|
| 325 |
) |
|
| 326 |
} |
|
| 327 | ||
| 328 | 6x |
y$prune <- bracket_expr(prune_list) |
| 329 | ||
| 330 |
# Start sorting pruned table. |
|
| 331 | 6x |
sort_list <- list() |
| 332 | ||
| 333 | 6x |
if (sort_criteria == "alpha") {
|
| 334 | 1x |
if (prune_freq == 0 && prune_diff == 0) {
|
| 335 |
# This is just a dummy step to get the right variable result. |
|
| 336 |
# No additional sorting is needed because during the data pre-processing step, |
|
| 337 |
# llt and/or hlt are converted to factors with alphabetically sorted levels. |
|
| 338 |
# So the order in y$table table is already alphabetically sorted. |
|
| 339 | 1x |
sort_list <- add_expr( |
| 340 | 1x |
sort_list, |
| 341 | 1x |
quote({
|
| 342 | ! |
pruned_and_sorted_result <- pruned_result |
| 343 | ! |
pruned_and_sorted_result |
| 344 |
}) |
|
| 345 |
) |
|
| 346 |
} else {
|
|
| 347 | ! |
sort_list <- add_expr( |
| 348 | ! |
sort_list, |
| 349 | ! |
quote( |
| 350 | ! |
criteria_fun <- function(tr) {
|
| 351 | ! |
inherits(tr, "ContentRow") |
| 352 |
} |
|
| 353 |
) |
|
| 354 |
) |
|
| 355 | ||
| 356 | ! |
sort_list <- add_expr( |
| 357 | ! |
sort_list, |
| 358 | ! |
quote({
|
| 359 | ! |
pruned_and_sorted_result <- rtables::trim_rows(pruned_result, criteria = criteria_fun) |
| 360 | ! |
pruned_and_sorted_result |
| 361 |
}) |
|
| 362 |
) |
|
| 363 |
} |
|
| 364 |
} else {
|
|
| 365 |
# Sort by decreasing frequency. |
|
| 366 | 5x |
sort_list <- add_expr( |
| 367 | 5x |
sort_list, |
| 368 | 5x |
substitute( |
| 369 | 5x |
expr = idx_split_col <- which(sapply(col_paths(result), tail, 1) == sort_freq_col), |
| 370 | 5x |
env = list(sort_freq_col = sort_freq_col) |
| 371 |
) |
|
| 372 |
) |
|
| 373 | ||
| 374 |
# When the "All Patients" column is present we only use that for scoring. |
|
| 375 | 5x |
scorefun_hlt <- if (add_total) {
|
| 376 | 4x |
quote(cont_n_onecol(idx_split_col)) |
| 377 |
} else {
|
|
| 378 | 1x |
quote(cont_n_allcols) |
| 379 |
} |
|
| 380 | 5x |
scorefun_llt <- if (add_total) {
|
| 381 | 4x |
quote(score_occurrences_cols(col_indices = seq(1, ncol(result)))) |
| 382 |
} else {
|
|
| 383 | 1x |
quote(score_occurrences) |
| 384 |
} |
|
| 385 | ||
| 386 | 5x |
if (one_term) {
|
| 387 | 1x |
term_var <- ifelse(is.null(hlt), llt, hlt) |
| 388 | ||
| 389 | 1x |
sort_list <- add_expr( |
| 390 | 1x |
sort_list, |
| 391 | 1x |
substitute( |
| 392 | 1x |
expr = {
|
| 393 | ! |
pruned_and_sorted_result <- pruned_result %>% |
| 394 | ! |
sort_at_path(path = c(term_var), scorefun = scorefun_llt) |
| 395 | ! |
pruned_and_sorted_result |
| 396 |
}, |
|
| 397 | 1x |
env = list( |
| 398 | 1x |
term_var = term_var, |
| 399 | 1x |
scorefun_llt = scorefun_llt |
| 400 |
) |
|
| 401 |
) |
|
| 402 |
) |
|
| 403 |
} else {
|
|
| 404 | 4x |
sort_list <- add_expr( |
| 405 | 4x |
sort_list, |
| 406 | 4x |
substitute( |
| 407 | 4x |
expr = {
|
| 408 | ! |
pruned_and_sorted_result <- pruned_result %>% |
| 409 | ! |
sort_at_path(path = c(hlt), scorefun = scorefun_hlt) %>% |
| 410 | ! |
sort_at_path(path = c(hlt, "*", llt), scorefun = scorefun_llt) |
| 411 |
}, |
|
| 412 | 4x |
env = list( |
| 413 | 4x |
llt = llt, |
| 414 | 4x |
hlt = hlt, |
| 415 | 4x |
scorefun_hlt = scorefun_hlt, |
| 416 | 4x |
scorefun_llt = scorefun_llt |
| 417 |
) |
|
| 418 |
) |
|
| 419 |
) |
|
| 420 | ||
| 421 | 4x |
if (prune_freq > 0 || prune_diff > 0) {
|
| 422 | 2x |
sort_list <- add_expr( |
| 423 | 2x |
sort_list, |
| 424 | 2x |
quote( |
| 425 | 2x |
criteria_fun <- function(tr) {
|
| 426 | ! |
inherits(tr, "ContentRow") |
| 427 |
} |
|
| 428 |
) |
|
| 429 |
) |
|
| 430 | ||
| 431 | 2x |
sort_list <- add_expr( |
| 432 | 2x |
sort_list, |
| 433 | 2x |
quote( |
| 434 | 2x |
pruned_and_sorted_result <- rtables::trim_rows(pruned_and_sorted_result, criteria = criteria_fun) |
| 435 |
) |
|
| 436 |
) |
|
| 437 |
} |
|
| 438 | ||
| 439 | 4x |
sort_list <- add_expr( |
| 440 | 4x |
sort_list, |
| 441 | 4x |
quote(pruned_and_sorted_result) |
| 442 |
) |
|
| 443 |
} |
|
| 444 |
} |
|
| 445 | 6x |
y$sort <- bracket_expr(sort_list) |
| 446 | ||
| 447 | 6x |
y |
| 448 |
} |
|
| 449 | ||
| 450 |
#' teal Module: Events by Term |
|
| 451 |
#' |
|
| 452 |
#' This module produces a table of events by term. |
|
| 453 |
#' |
|
| 454 |
#' @inheritParams module_arguments |
|
| 455 |
#' @inheritParams template_events |
|
| 456 |
#' @param arm_var ([teal.transform::choices_selected()])\cr object with all |
|
| 457 |
#' available choices and preselected option for variable names that can be used as `arm_var`. |
|
| 458 |
#' It defines the grouping variable(s) in the results table. |
|
| 459 |
#' If there are two elements selected for `arm_var`, |
|
| 460 |
#' second variable will be nested under the first variable. |
|
| 461 |
#' |
|
| 462 |
#' @inherit module_arguments return seealso |
|
| 463 |
#' |
|
| 464 |
#' @examples |
|
| 465 |
#' ADSL <- tmc_ex_adsl |
|
| 466 |
#' ADAE <- tmc_ex_adae |
|
| 467 |
#' |
|
| 468 |
#' app <- init( |
|
| 469 |
#' data = cdisc_data( |
|
| 470 |
#' ADSL = ADSL, |
|
| 471 |
#' ADAE = ADAE, |
|
| 472 |
#' code = " |
|
| 473 |
#' ADSL <- tmc_ex_adsl |
|
| 474 |
#' ADAE <- tmc_ex_adae |
|
| 475 |
#' " |
|
| 476 |
#' ), |
|
| 477 |
#' modules = modules( |
|
| 478 |
#' tm_t_events( |
|
| 479 |
#' label = "Adverse Event Table", |
|
| 480 |
#' dataname = "ADAE", |
|
| 481 |
#' arm_var = choices_selected(c("ARM", "ARMCD"), "ARM"),
|
|
| 482 |
#' llt = choices_selected( |
|
| 483 |
#' choices = variable_choices(ADAE, c("AETERM", "AEDECOD")),
|
|
| 484 |
#' selected = c("AEDECOD")
|
|
| 485 |
#' ), |
|
| 486 |
#' hlt = choices_selected( |
|
| 487 |
#' choices = variable_choices(ADAE, c("AEBODSYS", "AESOC")),
|
|
| 488 |
#' selected = "AEBODSYS" |
|
| 489 |
#' ), |
|
| 490 |
#' add_total = TRUE, |
|
| 491 |
#' event_type = "adverse event" |
|
| 492 |
#' ) |
|
| 493 |
#' ) |
|
| 494 |
#' ) |
|
| 495 |
#' if (interactive()) {
|
|
| 496 |
#' shinyApp(app$ui, app$server) |
|
| 497 |
#' } |
|
| 498 |
#' |
|
| 499 |
#' @export |
|
| 500 |
tm_t_events <- function(label, |
|
| 501 |
dataname, |
|
| 502 |
parentname = ifelse( |
|
| 503 |
inherits(arm_var, "data_extract_spec"), |
|
| 504 |
teal.transform::datanames_input(arm_var), |
|
| 505 |
"ADSL" |
|
| 506 |
), |
|
| 507 |
arm_var, |
|
| 508 |
hlt, |
|
| 509 |
llt, |
|
| 510 |
add_total = TRUE, |
|
| 511 |
total_label = default_total_label(), |
|
| 512 |
na_level = default_na_str(), |
|
| 513 |
event_type = "event", |
|
| 514 |
sort_criteria = c("freq_desc", "alpha"),
|
|
| 515 |
sort_freq_col = total_label, |
|
| 516 |
prune_freq = 0, |
|
| 517 |
prune_diff = 0, |
|
| 518 |
drop_arm_levels = TRUE, |
|
| 519 |
incl_overall_sum = TRUE, |
|
| 520 |
pre_output = NULL, |
|
| 521 |
post_output = NULL, |
|
| 522 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 523 | ! |
message("Initializing tm_t_events")
|
| 524 | ! |
checkmate::assert_string(label) |
| 525 | ! |
checkmate::assert_string(dataname) |
| 526 | ! |
checkmate::assert_string(parentname) |
| 527 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 528 | ! |
checkmate::assert_class(hlt, "choices_selected") |
| 529 | ! |
checkmate::assert_class(llt, "choices_selected") |
| 530 | ! |
checkmate::assert_string(event_type) |
| 531 | ! |
checkmate::assert_flag(add_total) |
| 532 | ! |
checkmate::assert_string(total_label) |
| 533 | ! |
checkmate::assert_string(na_level) |
| 534 | ! |
checkmate::assert_string(sort_freq_col) |
| 535 | ! |
checkmate::assert_scalar(prune_freq) |
| 536 | ! |
checkmate::assert_scalar(prune_diff) |
| 537 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 538 | ! |
checkmate::assert_flag(incl_overall_sum) |
| 539 | ! |
sort_criteria <- match.arg(sort_criteria) |
| 540 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 541 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 542 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 543 | ||
| 544 | ! |
args <- as.list(environment()) |
| 545 | ||
| 546 | ! |
data_extract_list <- list( |
| 547 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 548 | ! |
hlt = cs_to_des_select(hlt, dataname = dataname), |
| 549 | ! |
llt = cs_to_des_select(llt, dataname = dataname) |
| 550 |
) |
|
| 551 | ||
| 552 | ! |
module( |
| 553 | ! |
label = label, |
| 554 | ! |
ui = ui_t_events_byterm, |
| 555 | ! |
server = srv_t_events_byterm, |
| 556 | ! |
ui_args = c(data_extract_list, args), |
| 557 | ! |
server_args = c( |
| 558 | ! |
data_extract_list, |
| 559 | ! |
list( |
| 560 | ! |
dataname = dataname, |
| 561 | ! |
parentname = parentname, |
| 562 | ! |
event_type = event_type, |
| 563 | ! |
label = label, |
| 564 | ! |
total_label = total_label, |
| 565 | ! |
na_level = na_level, |
| 566 | ! |
sort_freq_col = sort_freq_col, |
| 567 | ! |
incl_overall_sum = incl_overall_sum, |
| 568 | ! |
basic_table_args = basic_table_args |
| 569 |
) |
|
| 570 |
), |
|
| 571 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 572 |
) |
|
| 573 |
} |
|
| 574 | ||
| 575 |
#' @keywords internal |
|
| 576 |
ui_t_events_byterm <- function(id, ...) {
|
|
| 577 | ! |
ns <- NS(id) |
| 578 | ! |
a <- list(...) |
| 579 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset(a$arm_var, a$hlt, a$llt) |
| 580 | ||
| 581 | ! |
teal.widgets::standard_layout( |
| 582 | ! |
output = teal.widgets::white_small_well( |
| 583 | ! |
teal.widgets::table_with_settings_ui(ns("table"))
|
| 584 |
), |
|
| 585 | ! |
encoding = tags$div( |
| 586 |
### Reporter |
|
| 587 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 588 |
### |
|
| 589 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 590 | ! |
teal.transform::datanames_input(a[c("arm_var", "hlt", "llt")]),
|
| 591 | ! |
teal.transform::data_extract_ui( |
| 592 | ! |
id = ns("arm_var"),
|
| 593 | ! |
label = "Select Treatment Variable", |
| 594 | ! |
data_extract_spec = a$arm_var, |
| 595 | ! |
is_single_dataset = is_single_dataset_value |
| 596 |
), |
|
| 597 | ! |
teal.transform::data_extract_ui( |
| 598 | ! |
id = ns("hlt"),
|
| 599 | ! |
label = "Event High Level Term", |
| 600 | ! |
data_extract_spec = a$hlt, |
| 601 | ! |
is_single_dataset = is_single_dataset_value |
| 602 |
), |
|
| 603 | ! |
teal.transform::data_extract_ui( |
| 604 | ! |
id = ns("llt"),
|
| 605 | ! |
label = "Event Low Level Term", |
| 606 | ! |
data_extract_spec = a$llt, |
| 607 | ! |
is_single_dataset = is_single_dataset_value |
| 608 |
), |
|
| 609 | ! |
checkboxInput(ns("add_total"), "Add All Patients columns", value = a$add_total),
|
| 610 | ! |
teal.widgets::panel_item( |
| 611 | ! |
"Additional table settings", |
| 612 | ! |
checkboxInput( |
| 613 | ! |
ns("drop_arm_levels"),
|
| 614 | ! |
label = "Drop columns not in filtered analysis dataset", |
| 615 | ! |
value = a$drop_arm_levels |
| 616 |
), |
|
| 617 | ! |
selectInput( |
| 618 | ! |
inputId = ns("sort_criteria"),
|
| 619 | ! |
label = "Sort Criteria", |
| 620 | ! |
choices = c( |
| 621 | ! |
"Decreasing frequency" = "freq_desc", |
| 622 | ! |
"Alphabetically" = "alpha" |
| 623 |
), |
|
| 624 | ! |
selected = a$sort_criteria, |
| 625 | ! |
multiple = FALSE |
| 626 |
), |
|
| 627 | ! |
helpText(tags$strong("Pruning Options:")),
|
| 628 | ! |
numericInput( |
| 629 | ! |
inputId = ns("prune_freq"),
|
| 630 | ! |
label = "Minimum Incidence Rate(%) in any of the treatment groups", |
| 631 | ! |
value = a$prune_freq, |
| 632 | ! |
min = 0, |
| 633 | ! |
max = 100, |
| 634 | ! |
step = 1, |
| 635 | ! |
width = "100%" |
| 636 |
), |
|
| 637 | ! |
numericInput( |
| 638 | ! |
inputId = ns("prune_diff"),
|
| 639 | ! |
label = "Minimum Difference Rate(%) between any of the treatment groups", |
| 640 | ! |
value = a$prune_diff, |
| 641 | ! |
min = 0, |
| 642 | ! |
max = 100, |
| 643 | ! |
step = 1, |
| 644 | ! |
width = "100%" |
| 645 |
) |
|
| 646 |
) |
|
| 647 |
), |
|
| 648 | ! |
forms = tagList( |
| 649 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 650 |
), |
|
| 651 | ! |
pre_output = a$pre_output, |
| 652 | ! |
post_output = a$post_output |
| 653 |
) |
|
| 654 |
} |
|
| 655 | ||
| 656 |
#' @keywords internal |
|
| 657 |
srv_t_events_byterm <- function(id, |
|
| 658 |
data, |
|
| 659 |
filter_panel_api, |
|
| 660 |
reporter, |
|
| 661 |
dataname, |
|
| 662 |
parentname, |
|
| 663 |
event_type, |
|
| 664 |
arm_var, |
|
| 665 |
hlt, |
|
| 666 |
llt, |
|
| 667 |
drop_arm_levels, |
|
| 668 |
incl_overall_sum, |
|
| 669 |
label, |
|
| 670 |
total_label, |
|
| 671 |
na_level, |
|
| 672 |
sort_freq_col, |
|
| 673 |
basic_table_args) {
|
|
| 674 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 675 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 676 | ! |
checkmate::assert_class(data, "reactive") |
| 677 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 678 | ||
| 679 | ! |
moduleServer(id, function(input, output, session) {
|
| 680 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 681 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 682 | ! |
data_extract = list(arm_var = arm_var, hlt = hlt, llt = llt), |
| 683 | ! |
datasets = data, |
| 684 | ! |
select_validation_rule = list( |
| 685 | ! |
arm_var = ~ if (length(.) != 1 && length(.) != 2) {
|
| 686 | ! |
"Please select 1 or 2 treatment variable values" |
| 687 |
}, |
|
| 688 | ! |
hlt = ~ if (length(selector_list()$llt()$select) + length(.) == 0) {
|
| 689 | ! |
"Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." |
| 690 |
}, |
|
| 691 | ! |
llt = ~ if (length(selector_list()$hlt()$select) + length(.) == 0) {
|
| 692 | ! |
"Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." |
| 693 |
} |
|
| 694 |
) |
|
| 695 |
) |
|
| 696 | ||
| 697 | ! |
iv_r <- reactive({
|
| 698 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 699 | ! |
iv$add_rule("prune_freq", shinyvalidate::sv_required("Please provide an Incidence Rate between 0 and 100 (%)."))
|
| 700 | ! |
iv$add_rule( |
| 701 | ! |
"prune_freq", |
| 702 | ! |
shinyvalidate::sv_between(0, 100, message_fmt = "Please provide an Incidence Rate between 0 and 100 (%).") |
| 703 |
) |
|
| 704 | ! |
iv$add_rule("prune_diff", shinyvalidate::sv_required("Please provide a Difference Rate between 0 and 100 (%)."))
|
| 705 | ! |
iv$add_rule( |
| 706 | ! |
"prune_diff", |
| 707 | ! |
shinyvalidate::sv_between(0, 100, message_fmt = "Please provide a Difference Rate between 0 and 100 (%).") |
| 708 |
) |
|
| 709 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 710 |
}) |
|
| 711 | ||
| 712 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 713 | ! |
datasets = data, |
| 714 | ! |
selector_list = selector_list, |
| 715 | ! |
merge_function = "dplyr::inner_join" |
| 716 |
) |
|
| 717 | ||
| 718 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 719 | ! |
datasets = data, |
| 720 | ! |
data_extract = list(arm_var = arm_var), |
| 721 | ! |
anl_name = "ANL_ADSL" |
| 722 |
) |
|
| 723 | ||
| 724 | ! |
anl_q <- reactive({
|
| 725 | ! |
data() %>% |
| 726 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 727 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 728 |
}) |
|
| 729 | ||
| 730 | ! |
merged <- list( |
| 731 | ! |
anl_input_r = anl_inputs, |
| 732 | ! |
adsl_input_r = adsl_inputs, |
| 733 | ! |
anl_q = anl_q |
| 734 |
) |
|
| 735 | ||
| 736 | ! |
validate_checks <- reactive({
|
| 737 | ! |
teal::validate_inputs(iv_r()) |
| 738 | ||
| 739 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 740 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 741 | ||
| 742 | ! |
input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) |
| 743 | ! |
input_level_term <- c( |
| 744 | ! |
as.vector(merged$anl_input_r()$columns_source$hlt), |
| 745 | ! |
as.vector(merged$anl_input_r()$columns_source$llt) |
| 746 |
) |
|
| 747 | ||
| 748 | ! |
validate( |
| 749 | ! |
if (length(input_arm_var) >= 1) {
|
| 750 | ! |
need(is.factor(adsl_filtered[[input_arm_var[[1]]]]), "Treatment variable is not a factor.") |
| 751 |
}, |
|
| 752 | ! |
if (length(input_arm_var) == 2) {
|
| 753 | ! |
need( |
| 754 | ! |
is.factor(adsl_filtered[[input_arm_var[[2]]]]) & all(!adsl_filtered[[input_arm_var[[2]]]] %in% c( |
| 755 | ! |
"", NA |
| 756 |
)), |
|
| 757 | ! |
"Please check nested treatment variable which needs to be a factor without NA or empty strings." |
| 758 |
) |
|
| 759 |
} |
|
| 760 |
) |
|
| 761 | ||
| 762 |
# validate inputs |
|
| 763 | ! |
validate_standard_inputs( |
| 764 | ! |
adsl = adsl_filtered, |
| 765 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 766 | ! |
anl = anl_filtered, |
| 767 | ! |
anlvars = c("USUBJID", "STUDYID", input_level_term),
|
| 768 | ! |
arm_var = input_arm_var[[1]] |
| 769 |
) |
|
| 770 |
}) |
|
| 771 | ||
| 772 |
# The R-code corresponding to the analysis. |
|
| 773 | ! |
table_q <- reactive({
|
| 774 | ! |
validate_checks() |
| 775 | ! |
ANL <- merged$anl_q()[["ANL"]] |
| 776 | ||
| 777 | ! |
input_hlt <- as.vector(merged$anl_input_r()$columns_source$hlt) |
| 778 | ! |
input_llt <- as.vector(merged$anl_input_r()$columns_source$llt) |
| 779 | ! |
label_hlt <- if (length(input_hlt) != 0) attributes(ANL[[input_hlt]])$label else NULL |
| 780 | ! |
label_llt <- if (length(input_llt) != 0) attributes(ANL[[input_llt]])$label else NULL |
| 781 | ||
| 782 | ! |
my_calls <- template_events( |
| 783 | ! |
dataname = "ANL", |
| 784 | ! |
parentname = "ANL_ADSL", |
| 785 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 786 | ! |
hlt = if (length(input_hlt) != 0) input_hlt else NULL, |
| 787 | ! |
llt = if (length(input_llt) != 0) input_llt else NULL, |
| 788 | ! |
label_hlt = label_hlt, |
| 789 | ! |
label_llt = label_llt, |
| 790 | ! |
add_total = input$add_total, |
| 791 | ! |
total_label = total_label, |
| 792 | ! |
na_level = na_level, |
| 793 | ! |
event_type = event_type, |
| 794 | ! |
sort_criteria = input$sort_criteria, |
| 795 | ! |
sort_freq_col = sort_freq_col, |
| 796 | ! |
prune_freq = input$prune_freq / 100, |
| 797 | ! |
prune_diff = input$prune_diff / 100, |
| 798 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 799 | ! |
incl_overall_sum = incl_overall_sum, |
| 800 | ! |
basic_table_args = basic_table_args |
| 801 |
) |
|
| 802 | ||
| 803 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 804 |
}) |
|
| 805 | ||
| 806 |
# Outputs to render. |
|
| 807 | ! |
table_r <- reactive({
|
| 808 | ! |
table_q()[["pruned_and_sorted_result"]] |
| 809 |
}) |
|
| 810 | ||
| 811 | ! |
teal.widgets::table_with_settings_srv( |
| 812 | ! |
id = "table", |
| 813 | ! |
table_r = table_r |
| 814 |
) |
|
| 815 | ||
| 816 |
# Render R code. |
|
| 817 | ! |
teal.widgets::verbatim_popup_srv( |
| 818 | ! |
id = "rcode", |
| 819 | ! |
verbatim_content = reactive(teal.code::get_code(table_q())), |
| 820 | ! |
title = label |
| 821 |
) |
|
| 822 | ||
| 823 |
### REPORTER |
|
| 824 | ! |
if (with_reporter) {
|
| 825 | ! |
card_fun <- function(comment, label) {
|
| 826 | ! |
card <- teal::report_card_template( |
| 827 | ! |
title = "Events by Term Table", |
| 828 | ! |
label = label, |
| 829 | ! |
with_filter = with_filter, |
| 830 | ! |
filter_panel_api = filter_panel_api |
| 831 |
) |
|
| 832 | ! |
card$append_text("Table", "header3")
|
| 833 | ! |
card$append_table(table_r()) |
| 834 | ! |
if (!comment == "") {
|
| 835 | ! |
card$append_text("Comment", "header3")
|
| 836 | ! |
card$append_text(comment) |
| 837 |
} |
|
| 838 | ! |
card$append_src(teal.code::get_code(table_q())) |
| 839 | ! |
card |
| 840 |
} |
|
| 841 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 842 |
} |
|
| 843 |
### |
|
| 844 |
}) |
|
| 845 |
} |
| 1 |
#' Template: Patient Profile Vitals Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a patient profile vitals [ggplot2::ggplot()] plot using ADaM datasets. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param paramcd_levels (`character`)\cr vector of all levels of `paramcd`. |
|
| 7 |
#' @param xaxis (`character`)\cr name of the time variable to put on the x-axis. |
|
| 8 |
#' |
|
| 9 |
#' @inherit template_arguments return |
|
| 10 |
#' |
|
| 11 |
#' @seealso [tm_g_pp_vitals()] |
|
| 12 |
#' |
|
| 13 |
#' @keywords internal |
|
| 14 |
template_vitals <- function(dataname = "ANL", |
|
| 15 |
paramcd = "PARAMCD", |
|
| 16 |
paramcd_levels = c("SYSBP", "DIABP", "PUL", "RESP", "OXYSAT", "WGHT", "TEMP"),
|
|
| 17 |
xaxis = "ADY", |
|
| 18 |
aval = lifecycle::deprecated(), |
|
| 19 |
aval_var = "AVAL", |
|
| 20 |
patient_id, |
|
| 21 |
font_size = 12L, |
|
| 22 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 23 | ! |
if (lifecycle::is_present(aval)) {
|
| 24 | ! |
aval_var <- aval |
| 25 | ! |
warning( |
| 26 | ! |
"The `aval` argument of `template_vitals()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 27 | ! |
"Please use the `aval_var` argument instead.", |
| 28 | ! |
call. = FALSE |
| 29 |
) |
|
| 30 |
} |
|
| 31 | ||
| 32 | ! |
checkmate::assert_string(dataname) |
| 33 | ! |
checkmate::assert_string(paramcd) |
| 34 | ! |
checkmate::assert_string(xaxis) |
| 35 | ! |
checkmate::assert_string(aval_var) |
| 36 | ! |
checkmate::assert_string(patient_id) |
| 37 | ! |
checkmate::assert_number(font_size) |
| 38 | ||
| 39 |
# Note: VSDY (study day of vital signs) was replaced with ADY (analysis day) |
|
| 40 | ! |
y <- list() |
| 41 | ! |
y$plot <- list() |
| 42 | ||
| 43 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 44 | ! |
teal.widgets::resolve_ggplot2_args( |
| 45 | ! |
user_plot = ggplot2_args, |
| 46 | ! |
module_plot = teal.widgets::ggplot2_args( |
| 47 | ! |
labs = list(title = paste0("Patient ID: ", patient_id)),
|
| 48 | ! |
theme = list( |
| 49 | ! |
text = substitute(ggplot2::element_text(size = font), list(font = font_size)), |
| 50 | ! |
axis.text.y = quote(ggplot2::element_blank()), |
| 51 | ! |
axis.ticks.y = quote(ggplot2::element_blank()), |
| 52 | ! |
plot.title = substitute(ggplot2::element_text(size = font), list(font = font_size)), |
| 53 | ! |
legend.position = "top", |
| 54 | ! |
panel.grid.minor = quote(ggplot2::element_line( |
| 55 | ! |
linewidth = 0.5, |
| 56 | ! |
linetype = "dotted", |
| 57 | ! |
colour = "grey" |
| 58 |
)), |
|
| 59 | ! |
panel.grid.major = quote(ggplot2::element_line( |
| 60 | ! |
linewidth = 0.5, |
| 61 | ! |
linetype = "dotted", |
| 62 | ! |
colour = "grey" |
| 63 |
)) |
|
| 64 |
) |
|
| 65 |
) |
|
| 66 |
), |
|
| 67 | ! |
ggtheme = "minimal" |
| 68 |
) |
|
| 69 | ||
| 70 | ! |
vital_plot <- add_expr( |
| 71 | ! |
list(), |
| 72 | ! |
substitute_names( |
| 73 | ! |
names = list( |
| 74 | ! |
dataname = as.name(dataname), |
| 75 | ! |
paramcd = as.name(paramcd), |
| 76 | ! |
xaxis = as.name(xaxis), |
| 77 | ! |
aval_var = as.name(aval_var) |
| 78 |
), |
|
| 79 | ! |
others = list(paramcd_levels = paramcd_levels), |
| 80 | ! |
expr = {
|
| 81 | ! |
vitals <- |
| 82 | ! |
dataname %>% |
| 83 | ! |
dplyr::group_by(paramcd, xaxis) %>% |
| 84 | ! |
dplyr::filter(paramcd %in% paramcd_levels) %>% |
| 85 | ! |
dplyr::summarise(aval_var = max(aval_var, na.rm = TRUE)) %>% |
| 86 | ! |
dplyr::mutate( |
| 87 | ! |
aval_var = ifelse(is.infinite(aval_var), NA, aval_var), |
| 88 | ! |
xaxis = as.numeric(xaxis) # difftime fails ggplot2::scale_x_continuous |
| 89 |
) |
|
| 90 |
} |
|
| 91 |
) |
|
| 92 |
) |
|
| 93 | ||
| 94 | ! |
vital_plot <- add_expr( |
| 95 | ! |
vital_plot, |
| 96 | ! |
substitute( |
| 97 | ! |
expr = {
|
| 98 | ! |
max_day <- max(vitals[[xaxis_char]], na.rm = TRUE) |
| 99 | ! |
max_aval <- max(vitals[[aval_char]], na.rm = TRUE) |
| 100 | ! |
max_aval_seq <- seq(0, max_aval, 10) |
| 101 | ||
| 102 | ! |
full_vita <- levels(dataname[[paramcd_char]]) |
| 103 | ! |
provided_vita <- paramcd_levels |
| 104 | ! |
known_vita <- c("SYSBP", "DIABP", "TEMP", "RESP", "OXYSAT", "PULSE")
|
| 105 | ||
| 106 | ! |
paramcd_levels_e <- known_vita[stats::na.omit(match(provided_vita, known_vita))] |
| 107 | ! |
len_paramcd_levels_e <- length(paramcd_levels_e) |
| 108 | ||
| 109 | ! |
all_colors <- stats::setNames(nestcolor::color_palette(length(full_vita), "stream"), full_vita) |
| 110 | ! |
vars_colors <- all_colors[provided_vita] |
| 111 | ! |
names(vars_colors) <- provided_vita |
| 112 | ||
| 113 | ! |
base_stats <- stats::setNames(c(140, 90, 38, 20, 94, 100), known_vita) |
| 114 | ! |
paramcd_stats_e <- base_stats[paramcd_levels_e] |
| 115 | ||
| 116 | ! |
base_labels <- stats::setNames(c("140mmHg", "90mmHg", "38\u00B0 C", "20/min", "94%", "100bpm"), known_vita)
|
| 117 | ! |
paramcd_labels_e <- base_labels[paramcd_levels_e] |
| 118 | ||
| 119 | ! |
base_stats_df <- data.frame( |
| 120 | ! |
x = rep(1, len_paramcd_levels_e), |
| 121 | ! |
y = paramcd_stats_e, |
| 122 | ! |
label = paramcd_labels_e, |
| 123 | ! |
color = paramcd_levels_e |
| 124 |
) |
|
| 125 | ||
| 126 | ! |
result_plot <- ggplot2::ggplot(data = vitals, mapping = ggplot2::aes(x = xaxis)) + # replaced VSDY |
| 127 | ! |
ggplot2::geom_line( |
| 128 | ! |
data = vitals, |
| 129 | ! |
mapping = ggplot2::aes(y = aval_var, color = paramcd), |
| 130 | ! |
size = 1.5, |
| 131 | ! |
alpha = 0.5 |
| 132 |
) + |
|
| 133 | ! |
ggplot2::scale_color_manual( |
| 134 | ! |
values = vars_colors |
| 135 |
) + |
|
| 136 | ! |
ggplot2::geom_text( |
| 137 | ! |
data = base_stats_df, |
| 138 | ! |
ggplot2::aes(x = x, y = y, label = label, color = color), |
| 139 | ! |
alpha = 1, |
| 140 | ! |
nudge_y = 2.2, |
| 141 | ! |
size = font_size_var / 3.5, |
| 142 | ! |
show.legend = FALSE |
| 143 |
) + |
|
| 144 | ! |
ggplot2::geom_hline( |
| 145 | ! |
data = base_stats_df, |
| 146 | ! |
ggplot2::aes(yintercept = y, color = color), |
| 147 | ! |
linetype = 2, |
| 148 | ! |
alpha = 0.5, |
| 149 | ! |
size = 1, |
| 150 | ! |
show.legend = FALSE |
| 151 |
) + |
|
| 152 | ! |
ggplot2::scale_y_continuous( |
| 153 | ! |
breaks = seq(0, max(vitals[[xaxis_char]], na.rm = TRUE), 50), |
| 154 | ! |
minor_breaks = seq(0, max(vitals[[aval_char]], na.rm = TRUE), 10) |
| 155 |
) + |
|
| 156 | ! |
ggplot2::geom_text( |
| 157 | ! |
data = data.frame( |
| 158 | ! |
x = rep(max_day, length(max_aval_seq)), |
| 159 | ! |
y = max_aval_seq, |
| 160 | ! |
l = as.character(max_aval_seq) |
| 161 |
), |
|
| 162 | ! |
ggplot2::aes( |
| 163 | ! |
x = x, |
| 164 | ! |
y = y, |
| 165 | ! |
label = l |
| 166 |
), |
|
| 167 | ! |
color = "black", |
| 168 | ! |
alpha = 1, |
| 169 | ! |
nudge_y = 2.2, |
| 170 | ! |
size = font_size_var / 3.5 |
| 171 |
) + |
|
| 172 | ! |
labs + |
| 173 | ! |
ggthemes + |
| 174 | ! |
themes |
| 175 | ||
| 176 | ! |
print(result_plot) |
| 177 |
}, |
|
| 178 | ! |
env = list( |
| 179 | ! |
dataname = as.name(dataname), |
| 180 | ! |
paramcd = as.name(paramcd), |
| 181 | ! |
paramcd_char = paramcd, |
| 182 | ! |
paramcd_levels = paramcd_levels, |
| 183 | ! |
xaxis = as.name(xaxis), |
| 184 | ! |
xaxis_char = xaxis, |
| 185 | ! |
aval_var = as.name(aval_var), |
| 186 | ! |
aval_char = aval_var, |
| 187 | ! |
patient_id = patient_id, |
| 188 | ! |
font_size_var = font_size, |
| 189 | ! |
labs = parsed_ggplot2_args$labs, |
| 190 | ! |
ggthemes = parsed_ggplot2_args$ggtheme, |
| 191 | ! |
themes = parsed_ggplot2_args$theme |
| 192 |
) |
|
| 193 |
) |
|
| 194 |
) |
|
| 195 | ||
| 196 | ! |
y$plot <- bracket_expr(vital_plot) |
| 197 | ! |
y |
| 198 |
} |
|
| 199 | ||
| 200 |
#' teal Module: Patient Profile Vitals Plot |
|
| 201 |
#' |
|
| 202 |
#' This module produces a patient profile vitals [ggplot2::ggplot()] type plot using ADaM datasets. |
|
| 203 |
#' |
|
| 204 |
#' This plot supports horizontal lines for the following 6 `PARAMCD` levels when they are present in `dataname`: |
|
| 205 |
#' `"SYSBP"`, `"DIABP"`, `"TEMP"`, `"RESP"`, `"OXYSAT"`. |
|
| 206 |
#' |
|
| 207 |
#' @inheritParams module_arguments |
|
| 208 |
#' @inheritParams template_vitals |
|
| 209 |
#' @param xaxis ([teal.transform::choices_selected()])\cr object with all |
|
| 210 |
#' available choices and preselected option for the time variable from `dataname` to be put on the plot x-axis. |
|
| 211 |
#' |
|
| 212 |
#' @inherit module_arguments return |
|
| 213 |
#' |
|
| 214 |
#' @examples |
|
| 215 |
#' library(nestcolor) |
|
| 216 |
#' |
|
| 217 |
#' ADSL <- tmc_ex_adsl |
|
| 218 |
#' ADVS <- tmc_ex_advs |
|
| 219 |
#' |
|
| 220 |
#' app <- init( |
|
| 221 |
#' data = cdisc_data( |
|
| 222 |
#' ADSL = ADSL, |
|
| 223 |
#' ADVS = ADVS, |
|
| 224 |
#' code = " |
|
| 225 |
#' ADSL <- tmc_ex_adsl |
|
| 226 |
#' ADVS <- tmc_ex_advs |
|
| 227 |
#' " |
|
| 228 |
#' ), |
|
| 229 |
#' modules = modules( |
|
| 230 |
#' tm_g_pp_vitals( |
|
| 231 |
#' label = "Vitals", |
|
| 232 |
#' dataname = "ADVS", |
|
| 233 |
#' parentname = "ADSL", |
|
| 234 |
#' patient_col = "USUBJID", |
|
| 235 |
#' plot_height = c(600L, 200L, 2000L), |
|
| 236 |
#' paramcd = choices_selected( |
|
| 237 |
#' choices = variable_choices(ADVS, "PARAMCD"), |
|
| 238 |
#' selected = "PARAMCD" |
|
| 239 |
#' ), |
|
| 240 |
#' xaxis = choices_selected( |
|
| 241 |
#' choices = variable_choices(ADVS, "ADY"), |
|
| 242 |
#' selected = "ADY" |
|
| 243 |
#' ), |
|
| 244 |
#' aval_var = choices_selected( |
|
| 245 |
#' choices = variable_choices(ADVS, "AVAL"), |
|
| 246 |
#' selected = "AVAL" |
|
| 247 |
#' ) |
|
| 248 |
#' ) |
|
| 249 |
#' ) |
|
| 250 |
#' ) |
|
| 251 |
#' if (interactive()) {
|
|
| 252 |
#' shinyApp(app$ui, app$server) |
|
| 253 |
#' } |
|
| 254 |
#' |
|
| 255 |
#' @export |
|
| 256 |
tm_g_pp_vitals <- function(label, |
|
| 257 |
dataname = "ADVS", |
|
| 258 |
parentname = "ADSL", |
|
| 259 |
patient_col = "USUBJID", |
|
| 260 |
paramcd = NULL, |
|
| 261 |
aval = lifecycle::deprecated(), |
|
| 262 |
aval_var = NULL, |
|
| 263 |
xaxis = NULL, |
|
| 264 |
font_size = c(12L, 12L, 25L), |
|
| 265 |
plot_height = c(700L, 200L, 2000L), |
|
| 266 |
plot_width = NULL, |
|
| 267 |
pre_output = NULL, |
|
| 268 |
post_output = NULL, |
|
| 269 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 270 | ! |
if (lifecycle::is_present(aval)) {
|
| 271 | ! |
aval_var <- aval |
| 272 | ! |
warning( |
| 273 | ! |
"The `aval` argument of `tm_g_pp_vitals()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 274 | ! |
"Please use the `aval_var` argument instead.", |
| 275 | ! |
call. = FALSE |
| 276 |
) |
|
| 277 |
} else {
|
|
| 278 | ! |
aval <- aval_var # resolves missing argument error |
| 279 |
} |
|
| 280 | ||
| 281 | ! |
message("Initializing tm_g_pp_vitals")
|
| 282 | ! |
checkmate::assert_string(label) |
| 283 | ! |
checkmate::assert_string(dataname) |
| 284 | ! |
checkmate::assert_string(parentname) |
| 285 | ! |
checkmate::assert_string(patient_col) |
| 286 | ! |
checkmate::assert_class(paramcd, "choices_selected", null.ok = TRUE) |
| 287 | ! |
checkmate::assert_class(aval_var, "choices_selected", null.ok = TRUE) |
| 288 | ! |
checkmate::assert_class(xaxis, "choices_selected", null.ok = TRUE) |
| 289 | ! |
checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE) |
| 290 | ! |
checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
| 291 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 292 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 293 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 294 | ! |
checkmate::assert_numeric( |
| 295 | ! |
plot_width[1], |
| 296 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 297 |
) |
|
| 298 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 299 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 300 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 301 | ! |
checkmate::assert_multi_class(paramcd, c("choices_selected", "data_extract_spec"), null.ok = TRUE)
|
| 302 | ! |
checkmate::assert_multi_class(aval_var, c("choices_selected", "data_extract_spec"), null.ok = TRUE)
|
| 303 | ! |
checkmate::assert_multi_class(xaxis, c("choices_selected", "data_extract_spec"), null.ok = TRUE)
|
| 304 | ||
| 305 | ! |
args <- as.list(environment()) |
| 306 | ! |
data_extract_list <- list( |
| 307 | ! |
paramcd = `if`(is.null(paramcd), NULL, cs_to_des_select(paramcd, dataname = dataname)), |
| 308 | ! |
aval_var = `if`(is.null(aval_var), NULL, cs_to_des_select(aval_var, dataname = dataname)), |
| 309 | ! |
xaxis = `if`(is.null(xaxis), NULL, cs_to_des_select(xaxis, dataname = dataname)) |
| 310 |
) |
|
| 311 | ||
| 312 | ! |
module( |
| 313 | ! |
label = label, |
| 314 | ! |
ui = ui_g_vitals, |
| 315 | ! |
ui_args = c(data_extract_list, args), |
| 316 | ! |
server = srv_g_vitals, |
| 317 | ! |
server_args = c( |
| 318 | ! |
data_extract_list, |
| 319 | ! |
list( |
| 320 | ! |
dataname = dataname, |
| 321 | ! |
parentname = parentname, |
| 322 | ! |
label = label, |
| 323 | ! |
patient_col = patient_col, |
| 324 | ! |
plot_height = plot_height, |
| 325 | ! |
plot_width = plot_width, |
| 326 | ! |
ggplot2_args = ggplot2_args |
| 327 |
) |
|
| 328 |
), |
|
| 329 | ! |
datanames = c(dataname, parentname) |
| 330 |
) |
|
| 331 |
} |
|
| 332 | ||
| 333 |
#' @keywords internal |
|
| 334 |
ui_g_vitals <- function(id, ...) {
|
|
| 335 | ! |
ui_args <- list(...) |
| 336 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 337 | ! |
ui_args$paramcd, |
| 338 | ! |
ui_args$aval_var, |
| 339 | ! |
ui_args$xaxis |
| 340 |
) |
|
| 341 | ||
| 342 | ! |
ns <- NS(id) |
| 343 | ! |
teal.widgets::standard_layout( |
| 344 | ! |
output = teal.widgets::plot_with_settings_ui(id = ns("vitals_plot")),
|
| 345 | ! |
encoding = tags$div( |
| 346 |
### Reporter |
|
| 347 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 348 |
### |
|
| 349 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 350 | ! |
teal.transform::datanames_input(ui_args[c("paramcd", "aval_var", "xaxis")]),
|
| 351 | ! |
teal.widgets::optionalSelectInput( |
| 352 | ! |
ns("patient_id"),
|
| 353 | ! |
"Select Patient:", |
| 354 | ! |
multiple = FALSE, |
| 355 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 356 |
), |
|
| 357 | ! |
teal.transform::data_extract_ui( |
| 358 | ! |
id = ns("paramcd"),
|
| 359 | ! |
label = "Select PARAMCD variable:", |
| 360 | ! |
data_extract_spec = ui_args$paramcd, |
| 361 | ! |
is_single_dataset = is_single_dataset_value |
| 362 |
), |
|
| 363 | ! |
uiOutput(ns("paramcd_levels")),
|
| 364 | ! |
teal.transform::data_extract_ui( |
| 365 | ! |
id = ns("xaxis"),
|
| 366 | ! |
label = "Select vital plot x-axis:", |
| 367 | ! |
data_extract_spec = ui_args$xaxis, |
| 368 | ! |
is_single_dataset = is_single_dataset_value |
| 369 |
), |
|
| 370 | ! |
teal.transform::data_extract_ui( |
| 371 | ! |
id = ns("aval_var"),
|
| 372 | ! |
label = "Select AVAL variable:", |
| 373 | ! |
data_extract_spec = ui_args$aval_var, |
| 374 | ! |
is_single_dataset = is_single_dataset_value |
| 375 |
), |
|
| 376 | ! |
teal.widgets::panel_item( |
| 377 | ! |
title = "Plot settings", |
| 378 | ! |
collapsed = TRUE, |
| 379 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 380 | ! |
ns("font_size"), "Font Size", ui_args$font_size,
|
| 381 | ! |
ticks = FALSE, step = 1 |
| 382 |
) |
|
| 383 |
) |
|
| 384 |
), |
|
| 385 | ! |
forms = tagList( |
| 386 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 387 |
), |
|
| 388 | ! |
pre_output = ui_args$pre_output, |
| 389 | ! |
post_output = ui_args$post_output |
| 390 |
) |
|
| 391 |
} |
|
| 392 | ||
| 393 |
#' @keywords internal |
|
| 394 |
srv_g_vitals <- function(id, |
|
| 395 |
data, |
|
| 396 |
reporter, |
|
| 397 |
filter_panel_api, |
|
| 398 |
dataname, |
|
| 399 |
parentname, |
|
| 400 |
patient_col, |
|
| 401 |
paramcd, |
|
| 402 |
aval_var, |
|
| 403 |
xaxis, |
|
| 404 |
plot_height, |
|
| 405 |
plot_width, |
|
| 406 |
label, |
|
| 407 |
ggplot2_args) {
|
|
| 408 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 409 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 410 | ! |
checkmate::assert_class(data, "reactive") |
| 411 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 412 | ||
| 413 | ! |
moduleServer(id, function(input, output, session) {
|
| 414 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 415 | ! |
patient_id <- reactive(input$patient_id) |
| 416 | ||
| 417 |
# Init |
|
| 418 | ! |
patient_data_base <- reactive(unique(data()[[parentname]][[patient_col]])) |
| 419 | ! |
teal.widgets::updateOptionalSelectInput( |
| 420 | ! |
session, |
| 421 | ! |
"patient_id", |
| 422 | ! |
choices = patient_data_base(), |
| 423 | ! |
selected = patient_data_base()[1] |
| 424 |
) |
|
| 425 | ||
| 426 | ! |
observeEvent(patient_data_base(), |
| 427 | ! |
handlerExpr = {
|
| 428 | ! |
teal.widgets::updateOptionalSelectInput( |
| 429 | ! |
session, |
| 430 | ! |
"patient_id", |
| 431 | ! |
choices = patient_data_base(), |
| 432 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 433 | ! |
patient_data_base() |
| 434 |
} else {
|
|
| 435 | ! |
intersect(patient_id(), patient_data_base()) |
| 436 |
} |
|
| 437 |
) |
|
| 438 |
}, |
|
| 439 | ! |
ignoreInit = TRUE |
| 440 |
) |
|
| 441 | ||
| 442 |
# Vitals tab ---- |
|
| 443 | ||
| 444 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 445 | ! |
data_extract = list(paramcd = paramcd, xaxis = xaxis, aval_var = aval_var), |
| 446 | ! |
datasets = data, |
| 447 | ! |
select_validation_rule = list( |
| 448 | ! |
paramcd = shinyvalidate::sv_required( |
| 449 | ! |
"Please select PARAMCD variable." |
| 450 |
), |
|
| 451 | ! |
xaxis = shinyvalidate::sv_required( |
| 452 | ! |
"Please select Vitals x-axis variable." |
| 453 |
), |
|
| 454 | ! |
aval_var = shinyvalidate::sv_required( |
| 455 | ! |
"Please select AVAL variable." |
| 456 |
) |
|
| 457 |
) |
|
| 458 |
) |
|
| 459 | ||
| 460 | ! |
iv_r <- reactive({
|
| 461 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 462 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required(
|
| 463 | ! |
"Please select a patient." |
| 464 |
)) |
|
| 465 | ! |
iv$add_rule("paramcd_levels_vals", shinyvalidate::sv_required(
|
| 466 | ! |
"Please select PARAMCD variable levels." |
| 467 |
)) |
|
| 468 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 469 |
}) |
|
| 470 | ||
| 471 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 472 | ! |
datasets = data, |
| 473 | ! |
selector_list = selector_list, |
| 474 | ! |
merge_function = "dplyr::left_join" |
| 475 |
) |
|
| 476 | ||
| 477 | ! |
anl_q <- reactive({
|
| 478 | ! |
data() %>% |
| 479 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 480 |
}) |
|
| 481 | ||
| 482 | ! |
merged <- list(anl_input_r = anl_inputs, anl_q = anl_q) |
| 483 | ||
| 484 | ! |
output$paramcd_levels <- renderUI({
|
| 485 | ! |
paramcd_var <- input[[extract_input("paramcd", dataname)]]
|
| 486 | ||
| 487 | ! |
req(paramcd_var) |
| 488 | ! |
req(input$patient_id) |
| 489 | ||
| 490 | ! |
vitals_dat <- merged$anl_q()[["ANL"]] |
| 491 | ! |
vitals_dat_sub <- vitals_dat[vitals_dat[[patient_col]] == patient_id(), ] |
| 492 | ! |
paramcd_col <- vitals_dat_sub[[paramcd_var]] |
| 493 | ! |
paramcd_col_levels <- unique(paramcd_col) |
| 494 | ||
| 495 | ! |
cur_selected <- isolate(input$paramcd_levels_vals) |
| 496 | ||
| 497 | ! |
selected <- if (length(cur_selected) > 0) {
|
| 498 | ! |
cur_selected |
| 499 |
} else {
|
|
| 500 | ! |
paramcd_col_levels |
| 501 |
} |
|
| 502 | ||
| 503 | ! |
tagList( |
| 504 | ! |
selectInput( |
| 505 | ! |
session$ns("paramcd_levels_vals"),
|
| 506 | ! |
"Select PARAMCD variable levels:", |
| 507 | ! |
selected = selected, |
| 508 | ! |
choices = paramcd_col_levels, |
| 509 | ! |
multiple = TRUE |
| 510 |
) |
|
| 511 |
) |
|
| 512 |
}) |
|
| 513 | ||
| 514 | ! |
all_q <- reactive({
|
| 515 | ! |
teal::validate_has_data(merged$anl_q()[["ANL"]], 1) |
| 516 | ||
| 517 | ! |
teal::validate_inputs(iv_r()) |
| 518 | ||
| 519 | ! |
validate( |
| 520 | ! |
need( |
| 521 | ! |
nrow(merged$anl_q()[["ANL"]][input$patient_id == merged$anl_q()[["ANL"]][, patient_col], ]) > 0, |
| 522 | ! |
"Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." |
| 523 |
) |
|
| 524 |
) |
|
| 525 | ||
| 526 | ! |
my_calls <- template_vitals( |
| 527 | ! |
dataname = "ANL", |
| 528 | ! |
paramcd = input[[extract_input("paramcd", dataname)]],
|
| 529 | ! |
paramcd_levels = input[["paramcd_levels_vals"]], |
| 530 | ! |
xaxis = input[[extract_input("xaxis", dataname)]],
|
| 531 | ! |
aval_var = input[[extract_input("aval_var", dataname)]],
|
| 532 | ! |
patient_id = patient_id(), |
| 533 | ! |
font_size = input[["font_size"]], |
| 534 | ! |
ggplot2_args = ggplot2_args |
| 535 |
) |
|
| 536 | ||
| 537 | ! |
teal.code::eval_code( |
| 538 | ! |
merged$anl_q(), |
| 539 | ! |
substitute( |
| 540 | ! |
expr = {
|
| 541 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 542 | ! |
}, env = list( |
| 543 | ! |
patient_col = patient_col, |
| 544 | ! |
patient_id = patient_id() |
| 545 |
) |
|
| 546 |
) |
|
| 547 |
) %>% |
|
| 548 | ! |
teal.code::eval_code(as.expression(my_calls)) |
| 549 |
}) |
|
| 550 | ||
| 551 | ! |
plot_r <- reactive(all_q()[["result_plot"]]) |
| 552 | ||
| 553 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 554 | ! |
id = "vitals_plot", |
| 555 | ! |
plot_r = plot_r, |
| 556 | ! |
height = plot_height, |
| 557 | ! |
width = plot_width |
| 558 |
) |
|
| 559 | ||
| 560 | ! |
teal.widgets::verbatim_popup_srv( |
| 561 | ! |
id = "rcode", |
| 562 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 563 | ! |
title = label |
| 564 |
) |
|
| 565 | ||
| 566 |
### REPORTER |
|
| 567 | ! |
if (with_reporter) {
|
| 568 | ! |
card_fun <- function(comment, label) {
|
| 569 | ! |
card <- teal::report_card_template( |
| 570 | ! |
title = "Patient Profile Vitals Plot", |
| 571 | ! |
label = label, |
| 572 | ! |
with_filter = with_filter, |
| 573 | ! |
filter_panel_api = filter_panel_api |
| 574 |
) |
|
| 575 | ! |
card$append_text("Plot", "header3")
|
| 576 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 577 | ! |
if (!comment == "") {
|
| 578 | ! |
card$append_text("Comment", "header3")
|
| 579 | ! |
card$append_text(comment) |
| 580 |
} |
|
| 581 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 582 | ! |
card |
| 583 |
} |
|
| 584 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 585 |
} |
|
| 586 |
### |
|
| 587 |
}) |
|
| 588 |
} |
| 1 |
#' Template: Exposure Table for Risk management plan |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate exposure table for risk management plan. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param row_by_var (`character`)\cr variable name used to split the values by rows. |
|
| 7 |
#' @param col_by_var (`character`)\cr variable name used to split the values by columns. |
|
| 8 |
#' @param drop_levels (`flag`)\cr whether empty rows should be removed from the table. |
|
| 9 |
#' @param paramcd_label (`character`)\cr the column from the `dataname` dataset where the |
|
| 10 |
#' value will be used to label the argument `paramcd`. |
|
| 11 |
#' @param add_total_row (`flag`)\cr whether a "total" level should be added after the others which includes all the |
|
| 12 |
#' levels that constitute the split. A custom label can be set for this level via the `total_row_label` argument. |
|
| 13 |
#' @param total_row_label (`character`)\cr string to display as total row label if row is |
|
| 14 |
#' enabled (see `add_total_row`). |
|
| 15 |
#' |
|
| 16 |
#' @inherit template_arguments return |
|
| 17 |
#' |
|
| 18 |
#' @seealso [tm_t_exposure()] |
|
| 19 |
#' |
|
| 20 |
#' @keywords internal |
|
| 21 |
template_exposure <- function(parentname, |
|
| 22 |
dataname, |
|
| 23 |
id_var, |
|
| 24 |
paramcd, |
|
| 25 |
paramcd_label = NULL, |
|
| 26 |
row_by_var, |
|
| 27 |
col_by_var = NULL, |
|
| 28 |
add_total = FALSE, |
|
| 29 |
total_label = "Total", |
|
| 30 |
add_total_row = TRUE, |
|
| 31 |
total_row_label = "Total number of patients and patient time*", |
|
| 32 |
drop_levels = TRUE, |
|
| 33 |
na_level = default_na_str(), |
|
| 34 |
aval_var, |
|
| 35 |
avalu_var, |
|
| 36 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 37 | 3x |
checkmate::assert_string(dataname) |
| 38 | 3x |
checkmate::assert_string(parentname) |
| 39 | 3x |
checkmate::assert_string(row_by_var) |
| 40 | 3x |
checkmate::assert_character(col_by_var, null.ok = TRUE) |
| 41 | 3x |
checkmate::assert_string(paramcd) |
| 42 | 3x |
checkmate::assert_string(id_var) |
| 43 | 3x |
checkmate::assert_flag(add_total) |
| 44 | 3x |
checkmate::assert_string(total_label) |
| 45 | 3x |
checkmate::assert_flag(add_total_row) |
| 46 | 3x |
checkmate::assert_string(total_row_label) |
| 47 | 3x |
checkmate::assert_string(na_level) |
| 48 | 3x |
checkmate::assert_string(aval_var) |
| 49 | 3x |
checkmate::assert_string(avalu_var, null.ok = TRUE) |
| 50 | 3x |
checkmate::assert_flag(drop_levels) |
| 51 | ||
| 52 | 3x |
y <- list() |
| 53 | 3x |
data_list <- list() |
| 54 | ||
| 55 | 3x |
if (length(col_by_var) == 0) {
|
| 56 | ! |
col_by_var <- NULL |
| 57 |
} |
|
| 58 | ||
| 59 | 3x |
data_list <- add_expr( |
| 60 | 3x |
data_list, |
| 61 | 3x |
substitute( |
| 62 | 3x |
anl <- dataname, |
| 63 | 3x |
env = list( |
| 64 | 3x |
dataname = as.name(dataname) |
| 65 |
) |
|
| 66 |
) |
|
| 67 |
) |
|
| 68 | ||
| 69 | 3x |
data_list <- add_expr( |
| 70 | 3x |
data_list, |
| 71 | 3x |
substitute( |
| 72 | 3x |
dataname <- df_explicit_na(dataname, na_level = na_str), |
| 73 | 3x |
env = list( |
| 74 | 3x |
dataname = as.name("anl"),
|
| 75 | 3x |
na_str = na_level |
| 76 |
) |
|
| 77 |
) |
|
| 78 |
) |
|
| 79 | 3x |
y$data <- bracket_expr(data_list) |
| 80 | ||
| 81 |
# layout start |
|
| 82 | 3x |
y$layout_prep <- quote(split_fun <- drop_split_levels) |
| 83 | ||
| 84 | 3x |
if (is.null(paramcd_label)) {
|
| 85 | 2x |
paramcd_label <- paramcd |
| 86 |
} |
|
| 87 | ||
| 88 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 89 | 3x |
teal.widgets::resolve_basic_table_args( |
| 90 | 3x |
user_table = basic_table_args, |
| 91 | 3x |
module_table = teal.widgets::basic_table_args( |
| 92 | 3x |
show_colcounts = TRUE, |
| 93 | 3x |
main_footer = paste0("* Patient time is the sum of ", paramcd_label)
|
| 94 |
) |
|
| 95 |
) |
|
| 96 |
) |
|
| 97 | ||
| 98 | 3x |
layout_list <- list() |
| 99 | 3x |
layout_list <- add_expr( |
| 100 | 3x |
layout_list, |
| 101 | 3x |
parsed_basic_table_args |
| 102 |
) |
|
| 103 | ||
| 104 | 3x |
if (length(col_by_var) > 0) {
|
| 105 | 3x |
if (add_total) {
|
| 106 | ! |
layout_list <- add_expr( |
| 107 | ! |
layout_list, |
| 108 | ! |
substitute( |
| 109 | ! |
rtables::split_cols_by(col_by_var, split_fun = add_overall_level(total_label, first = FALSE)), |
| 110 | ! |
env = list( |
| 111 | ! |
col_by_var = col_by_var, |
| 112 | ! |
total_label = total_label |
| 113 |
) |
|
| 114 |
) |
|
| 115 |
) |
|
| 116 |
} else {
|
|
| 117 | 3x |
layout_list <- add_expr( |
| 118 | 3x |
layout_list, |
| 119 | 3x |
substitute( |
| 120 | 3x |
rtables::split_cols_by(col_by_var), |
| 121 | 3x |
env = list( |
| 122 | 3x |
col_by_var = col_by_var |
| 123 |
) |
|
| 124 |
) |
|
| 125 |
) |
|
| 126 |
} |
|
| 127 |
} |
|
| 128 | ||
| 129 | 3x |
layout_list <- add_expr( |
| 130 | 3x |
layout_list, |
| 131 | 3x |
substitute( |
| 132 | 3x |
analyze_patients_exposure_in_cols( |
| 133 | 3x |
var = row_by_var, |
| 134 | 3x |
ex_var = aval_var, |
| 135 | 3x |
col_split = TRUE, |
| 136 | 3x |
add_total_level = add_total_row, |
| 137 | 3x |
na_str = na_str, |
| 138 | 3x |
.labels = c( |
| 139 | 3x |
n_patients = "Number of Patients", |
| 140 | 3x |
sum_exposure = ifelse( |
| 141 | 3x |
avalu_var == " ", |
| 142 | 3x |
paste("Sum of", paramcd),
|
| 143 | 3x |
paste("Sum of", paramcd, sprintf("(%s)", avalu_var))
|
| 144 |
) |
|
| 145 |
), |
|
| 146 | 3x |
custom_label = total_row_label |
| 147 |
), |
|
| 148 | 3x |
env = list( |
| 149 | 3x |
row_by_var = row_by_var, |
| 150 | 3x |
aval_var = aval_var, |
| 151 | 3x |
add_total_row = add_total_row, |
| 152 | 3x |
na_str = na_level, |
| 153 | 3x |
avalu_var = avalu_var, |
| 154 | 3x |
paramcd = paramcd, |
| 155 | 3x |
total_row_label = total_row_label |
| 156 |
) |
|
| 157 |
) |
|
| 158 |
) |
|
| 159 | ||
| 160 | 3x |
split_label <- substitute( |
| 161 | 3x |
expr = teal.data::col_labels(dataname[row_by_var], fill = TRUE), |
| 162 | 3x |
env = list( |
| 163 | 3x |
dataname = as.name(dataname), |
| 164 | 3x |
row_by_var = row_by_var |
| 165 |
) |
|
| 166 |
) |
|
| 167 | ||
| 168 | 3x |
layout_list <- add_expr( |
| 169 | 3x |
layout_list, |
| 170 | 3x |
substitute( |
| 171 | 3x |
analyze_patients_exposure_in_cols( |
| 172 | 3x |
var = row_by_var, |
| 173 | 3x |
col_split = FALSE, |
| 174 | 3x |
na_str = na_str |
| 175 |
) %>% |
|
| 176 | 3x |
append_topleft(c(split_label)), |
| 177 | 3x |
env = list( |
| 178 | 3x |
row_by_var = row_by_var, |
| 179 | 3x |
na_str = na_level, |
| 180 | 3x |
split_label = split_label |
| 181 |
) |
|
| 182 |
) |
|
| 183 |
) |
|
| 184 | ||
| 185 | 3x |
y$layout <- substitute( |
| 186 | 3x |
expr = lyt <- layout_pipe, |
| 187 | 3x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 188 |
) |
|
| 189 | ||
| 190 | 3x |
y$table <- substitute( |
| 191 | 3x |
expr = {
|
| 192 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 193 | ! |
result |
| 194 |
}, |
|
| 195 | 3x |
env = list(parent = as.name(parentname)) |
| 196 |
) |
|
| 197 | ||
| 198 | 3x |
if (drop_levels) {
|
| 199 | 3x |
y$table <- substitute( |
| 200 | 3x |
expr = {
|
| 201 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 202 | ! |
rtables::prune_table(result) |
| 203 |
}, |
|
| 204 | 3x |
env = list(parent = as.name(parentname)) |
| 205 |
) |
|
| 206 |
} |
|
| 207 | 3x |
y |
| 208 |
} |
|
| 209 | ||
| 210 |
#' teal Module: Exposure Table for Risk management plan |
|
| 211 |
#' |
|
| 212 |
#' The module produces an exposure table for risk management plan. |
|
| 213 |
#' |
|
| 214 |
#' @inheritParams module_arguments |
|
| 215 |
#' @inheritParams template_exposure |
|
| 216 |
#' @param row_by_var ([teal.transform::choices_selected()])\cr |
|
| 217 |
#' object with all available choices and preselected option for |
|
| 218 |
#' variable names that can be used to split rows. |
|
| 219 |
#' @param col_by_var ([teal.transform::choices_selected()])\cr |
|
| 220 |
#' object with all available choices and preselected option for |
|
| 221 |
#' variable names that can be used to split columns. |
|
| 222 |
#' @param parcat ([teal.transform::choices_selected()])\cr |
|
| 223 |
#' object with all available choices and preselected option for |
|
| 224 |
#' parameter category values. |
|
| 225 |
#' @param paramcd_label (`character`)\cr the column from the dataset where the value will be used to |
|
| 226 |
#' label the argument `paramcd`. |
|
| 227 |
#' |
|
| 228 |
#' @inherit module_arguments return seealso |
|
| 229 |
#' |
|
| 230 |
#' @examples |
|
| 231 |
#' library(dplyr) |
|
| 232 |
#' |
|
| 233 |
#' data <- teal_data() |
|
| 234 |
#' data <- within(data, {
|
|
| 235 |
#' ADSL <- tmc_ex_adsl |
|
| 236 |
#' ADEX <- tmc_ex_adex |
|
| 237 |
#' |
|
| 238 |
#' set.seed(1, kind = "Mersenne-Twister") |
|
| 239 |
#' labels <- col_labels(ADEX, fill = FALSE) |
|
| 240 |
#' ADEX <- ADEX %>% |
|
| 241 |
#' distinct(USUBJID, .keep_all = TRUE) %>% |
|
| 242 |
#' mutate( |
|
| 243 |
#' PARAMCD = "TDURD", |
|
| 244 |
#' PARAM = "Overall duration (days)", |
|
| 245 |
#' AVAL = sample(x = seq(1, 200), size = n(), replace = TRUE), |
|
| 246 |
#' AVALU = "Days" |
|
| 247 |
#' ) %>% |
|
| 248 |
#' bind_rows(ADEX) |
|
| 249 |
#' col_labels(ADEX) <- labels |
|
| 250 |
#' }) |
|
| 251 |
#' |
|
| 252 |
#' datanames <- c("ADSL", "ADEX")
|
|
| 253 |
#' datanames(data) <- datanames |
|
| 254 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 255 |
#' |
|
| 256 |
#' app <- init( |
|
| 257 |
#' data = data, |
|
| 258 |
#' modules = modules( |
|
| 259 |
#' tm_t_exposure( |
|
| 260 |
#' label = "Duration of Exposure Table", |
|
| 261 |
#' dataname = "ADEX", |
|
| 262 |
#' paramcd = choices_selected( |
|
| 263 |
#' choices = value_choices(data[["ADEX"]], "PARAMCD", "PARAM"), |
|
| 264 |
#' selected = "TDURD" |
|
| 265 |
#' ), |
|
| 266 |
#' col_by_var = choices_selected( |
|
| 267 |
#' choices = variable_choices(data[["ADEX"]], subset = c("SEX", "ARM")),
|
|
| 268 |
#' selected = "SEX" |
|
| 269 |
#' ), |
|
| 270 |
#' row_by_var = choices_selected( |
|
| 271 |
#' choices = variable_choices(data[["ADEX"]], subset = c("RACE", "REGION1", "STRATA1", "SEX")),
|
|
| 272 |
#' selected = "RACE" |
|
| 273 |
#' ), |
|
| 274 |
#' parcat = choices_selected( |
|
| 275 |
#' choices = value_choices(data[["ADEX"]], "PARCAT2"), |
|
| 276 |
#' selected = "Drug A" |
|
| 277 |
#' ), |
|
| 278 |
#' add_total = FALSE |
|
| 279 |
#' ) |
|
| 280 |
#' ), |
|
| 281 |
#' filter = teal_slices(teal_slice("ADSL", "SAFFL", selected = "Y"))
|
|
| 282 |
#' ) |
|
| 283 |
#' if (interactive()) {
|
|
| 284 |
#' shinyApp(app$ui, app$server) |
|
| 285 |
#' } |
|
| 286 |
#' |
|
| 287 |
#' @export |
|
| 288 |
tm_t_exposure <- function(label, |
|
| 289 |
dataname, |
|
| 290 |
parentname = ifelse( |
|
| 291 |
inherits(col_by_var, "data_extract_spec"), |
|
| 292 |
teal.transform::datanames_input(col_by_var), |
|
| 293 |
"ADSL" |
|
| 294 |
), |
|
| 295 |
row_by_var, |
|
| 296 |
col_by_var, |
|
| 297 |
paramcd = teal.transform::choices_selected( |
|
| 298 |
choices = teal.transform::value_choices(dataname, "PARAMCD", "PARAM"), |
|
| 299 |
selected = "TDURD" |
|
| 300 |
), |
|
| 301 |
paramcd_label = "PARAM", |
|
| 302 |
id_var = teal.transform::choices_selected( |
|
| 303 |
teal.transform::variable_choices(dataname, subset = "USUBJID"), |
|
| 304 |
selected = "USUBJID", |
|
| 305 |
fixed = TRUE |
|
| 306 |
), |
|
| 307 |
parcat, |
|
| 308 |
aval_var = teal.transform::choices_selected( |
|
| 309 |
teal.transform::variable_choices(dataname, subset = "AVAL"), |
|
| 310 |
selected = "AVAL", |
|
| 311 |
fixed = TRUE |
|
| 312 |
), |
|
| 313 |
avalu_var = teal.transform::choices_selected( |
|
| 314 |
teal.transform::variable_choices(dataname, subset = "AVALU"), |
|
| 315 |
selected = "AVALU", |
|
| 316 |
fixed = TRUE |
|
| 317 |
), |
|
| 318 |
add_total, |
|
| 319 |
total_label = default_total_label(), |
|
| 320 |
add_total_row = TRUE, |
|
| 321 |
total_row_label = "Total number of patients and patient time*", |
|
| 322 |
na_level = default_na_str(), |
|
| 323 |
pre_output = NULL, |
|
| 324 |
post_output = NULL, |
|
| 325 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 326 | ! |
message("Initializing tm_t_exposure")
|
| 327 | ! |
checkmate::assert_string(label) |
| 328 | ! |
checkmate::assert_string(dataname) |
| 329 | ! |
checkmate::assert_string(parentname) |
| 330 | ! |
checkmate::assert_string(na_level) |
| 331 | ! |
checkmate::assert_class(row_by_var, "choices_selected") |
| 332 | ! |
checkmate::assert_class(col_by_var, "choices_selected") |
| 333 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 334 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 335 | ! |
checkmate::assert_class(parcat, "choices_selected") |
| 336 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 337 | ! |
checkmate::assert_class(avalu_var, "choices_selected") |
| 338 | ! |
checkmate::assert_flag(add_total) |
| 339 | ! |
checkmate::assert_string(total_label) |
| 340 | ! |
checkmate::assert_flag(add_total_row) |
| 341 | ! |
checkmate::assert_string(total_row_label) |
| 342 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 343 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 344 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 345 | ||
| 346 | ! |
data_extract_list <- list( |
| 347 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 348 | ! |
row_by_var = cs_to_des_select(row_by_var, dataname = dataname), |
| 349 | ! |
col_by_var = cs_to_des_select(col_by_var, dataname = parentname), |
| 350 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 351 | ! |
parcat = cs_to_des_filter(parcat, dataname = dataname), |
| 352 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 353 | ! |
avalu_var = cs_to_des_select(avalu_var, dataname = dataname) |
| 354 |
) |
|
| 355 | ||
| 356 | ! |
args <- as.list(environment()) |
| 357 | ! |
module( |
| 358 | ! |
label = label, |
| 359 | ! |
ui = ui_t_exposure, |
| 360 | ! |
server = srv_t_exposure, |
| 361 | ! |
ui_args = c(data_extract_list, args), |
| 362 | ! |
server_args = c( |
| 363 | ! |
data_extract_list, |
| 364 | ! |
list( |
| 365 | ! |
dataname = dataname, |
| 366 | ! |
parentname = parentname, |
| 367 | ! |
label = label, |
| 368 | ! |
total_label = total_label, |
| 369 | ! |
total_row_label = total_row_label, |
| 370 | ! |
na_level = na_level, |
| 371 | ! |
basic_table_args = basic_table_args, |
| 372 | ! |
paramcd_label = paramcd_label |
| 373 |
) |
|
| 374 |
), |
|
| 375 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 376 |
) |
|
| 377 |
} |
|
| 378 | ||
| 379 | ||
| 380 |
#' @keywords internal |
|
| 381 |
ui_t_exposure <- function(id, ...) {
|
|
| 382 | ! |
ns <- NS(id) |
| 383 | ! |
a <- list(...) # module args |
| 384 | ||
| 385 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 386 | ! |
a$paramcd, |
| 387 | ! |
a$col_by_var, |
| 388 | ! |
a$row_by_var, |
| 389 | ! |
a$id_var, |
| 390 | ! |
a$parcat, |
| 391 | ! |
a$aval_var, |
| 392 | ! |
a$avalu_var |
| 393 |
) |
|
| 394 | ||
| 395 | ! |
teal.widgets::standard_layout( |
| 396 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 397 | ! |
encoding = tags$div( |
| 398 |
### Reporter |
|
| 399 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 400 |
### |
|
| 401 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 402 | ! |
teal.transform::datanames_input(a[c( |
| 403 | ! |
"paramcd", "col_by_var", "row_by_var", "id_var", "parcat", "aval_var", "avalu_var" |
| 404 |
)]), |
|
| 405 | ! |
teal.transform::data_extract_ui( |
| 406 | ! |
id = ns("paramcd"),
|
| 407 | ! |
label = "Select the Parameter", |
| 408 | ! |
data_extract_spec = a$paramcd, |
| 409 | ! |
is_single_dataset = is_single_dataset_value |
| 410 |
), |
|
| 411 | ! |
teal.transform::data_extract_ui( |
| 412 | ! |
id = ns("parcat"),
|
| 413 | ! |
label = "Select the Parameter Category", |
| 414 | ! |
data_extract_spec = a$parcat, |
| 415 | ! |
is_single_dataset = is_single_dataset_value |
| 416 |
), |
|
| 417 | ! |
teal.transform::data_extract_ui( |
| 418 | ! |
id = ns("col_by_var"),
|
| 419 | ! |
label = "Select Column by Variable", |
| 420 | ! |
data_extract_spec = a$col_by_var, |
| 421 | ! |
is_single_dataset = is_single_dataset_value |
| 422 |
), |
|
| 423 | ! |
teal.transform::data_extract_ui( |
| 424 | ! |
id = ns("row_by_var"),
|
| 425 | ! |
label = "Select Row by Variable", |
| 426 | ! |
data_extract_spec = a$row_by_var, |
| 427 | ! |
is_single_dataset = is_single_dataset_value |
| 428 |
), |
|
| 429 | ! |
checkboxInput(ns("add_total_row"), "Add Total row", value = a$add_total_row),
|
| 430 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total),
|
| 431 | ! |
teal.widgets::panel_group( |
| 432 | ! |
teal.widgets::panel_item( |
| 433 | ! |
"Additional Variables Info", |
| 434 | ! |
teal.transform::data_extract_ui( |
| 435 | ! |
id = ns("id_var"),
|
| 436 | ! |
label = "Subject Identifier", |
| 437 | ! |
data_extract_spec = a$id_var, |
| 438 | ! |
is_single_dataset = is_single_dataset_value |
| 439 |
), |
|
| 440 | ! |
teal.transform::data_extract_ui( |
| 441 | ! |
id = ns("aval_var"),
|
| 442 | ! |
label = "Analysis Value Variable", |
| 443 | ! |
data_extract_spec = a$aval_var, |
| 444 | ! |
is_single_dataset = is_single_dataset_value |
| 445 |
), |
|
| 446 | ! |
teal.transform::data_extract_ui( |
| 447 | ! |
id = ns("avalu_var"),
|
| 448 | ! |
label = "Analysis Value Unit Variable", |
| 449 | ! |
data_extract_spec = a$avalu_var, |
| 450 | ! |
is_single_dataset = is_single_dataset_value |
| 451 |
) |
|
| 452 |
) |
|
| 453 |
) |
|
| 454 |
), |
|
| 455 | ! |
forms = tagList( |
| 456 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 457 |
), |
|
| 458 | ! |
pre_output = a$pre_output, |
| 459 | ! |
post_output = a$post_output |
| 460 |
) |
|
| 461 |
} |
|
| 462 | ||
| 463 |
#' @keywords internal |
|
| 464 |
srv_t_exposure <- function(id, |
|
| 465 |
data, |
|
| 466 |
reporter, |
|
| 467 |
filter_panel_api, |
|
| 468 |
dataname, |
|
| 469 |
parentname, |
|
| 470 |
paramcd, |
|
| 471 |
paramcd_label, |
|
| 472 |
id_var, |
|
| 473 |
row_by_var, |
|
| 474 |
col_by_var, |
|
| 475 |
parcat, |
|
| 476 |
aval_var, |
|
| 477 |
avalu_var, |
|
| 478 |
na_level, |
|
| 479 |
label, |
|
| 480 |
total_label, |
|
| 481 |
total_row_label, |
|
| 482 |
basic_table_args = basic_table_args) {
|
|
| 483 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 484 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 485 | ! |
checkmate::assert_class(data, "reactive") |
| 486 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 487 | ! |
moduleServer(id, function(input, output, session) {
|
| 488 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 489 | ! |
rule_intersection <- function(other) {
|
| 490 | ! |
function(value) {
|
| 491 | ! |
others <- selector_list()[[other]]()$select |
| 492 | ! |
if (length(intersect(value, others)) > 0L) {
|
| 493 | ! |
"Column by and row by variables should not be the same." |
| 494 |
} |
|
| 495 |
} |
|
| 496 |
} |
|
| 497 | ||
| 498 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 499 | ! |
data_extract = list( |
| 500 | ! |
id_var = id_var, |
| 501 | ! |
paramcd = paramcd, |
| 502 | ! |
row_by_var = row_by_var, |
| 503 | ! |
col_by_var = col_by_var, |
| 504 | ! |
parcat = parcat, |
| 505 | ! |
aval_var = aval_var, |
| 506 | ! |
avalu_var = avalu_var |
| 507 |
), |
|
| 508 | ! |
datasets = data, |
| 509 | ! |
select_validation_rule = list( |
| 510 | ! |
id_var = shinyvalidate::sv_required("Subject Identifier is required"),
|
| 511 | ! |
col_by_var = shinyvalidate::compose_rules( |
| 512 | ! |
shinyvalidate::sv_optional(), |
| 513 | ! |
rule_intersection("row_by_var")
|
| 514 |
), |
|
| 515 | ! |
row_by_var = shinyvalidate::compose_rules( |
| 516 | ! |
shinyvalidate::sv_required("Please select a row by variable."),
|
| 517 | ! |
rule_intersection("col_by_var")
|
| 518 |
), |
|
| 519 | ! |
aval_var = shinyvalidate::sv_required("Please select an analysis variable."),
|
| 520 | ! |
avalu_var = shinyvalidate::sv_required("Please select an analysis unit variable.")
|
| 521 |
), |
|
| 522 | ! |
filter_validation_rule = list( |
| 523 | ! |
paramcd = shinyvalidate::sv_required("Please select a parameter value."),
|
| 524 | ! |
parcat = shinyvalidate::sv_required("Please select a parameter category value.")
|
| 525 |
) |
|
| 526 |
) |
|
| 527 | ||
| 528 | ! |
iv_r <- reactive({
|
| 529 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 530 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 531 |
}) |
|
| 532 | ||
| 533 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 534 | ! |
datasets = data, |
| 535 | ! |
selector_list = selector_list, |
| 536 | ! |
merge_function = "dplyr::inner_join" |
| 537 |
) |
|
| 538 | ||
| 539 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 540 | ! |
datasets = data, |
| 541 | ! |
data_extract = list(col_by_var = col_by_var), |
| 542 | ! |
anl_name = "ANL_ADSL" |
| 543 |
) |
|
| 544 | ||
| 545 | ! |
anl_q <- reactive({
|
| 546 | ! |
data() %>% |
| 547 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 548 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 549 |
}) |
|
| 550 | ||
| 551 | ! |
merged <- list( |
| 552 | ! |
anl_input_r = anl_inputs, |
| 553 | ! |
adsl_input_r = adsl_inputs, |
| 554 | ! |
anl_q = anl_q |
| 555 |
) |
|
| 556 | ||
| 557 | ! |
validate_checks <- reactive({
|
| 558 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 559 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 560 | ||
| 561 | ! |
teal::validate_inputs(iv_r()) |
| 562 | ||
| 563 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 564 | ! |
input_id_var <- names(merged$anl_input_r()$columns_source$id_var) |
| 565 | ! |
input_row_by_var <- names(merged$anl_input_r()$columns_source$row_by_var) |
| 566 | ! |
input_col_by_var <- names(merged$adsl_input_r()$columns_source$col_by_var) |
| 567 | ! |
input_parcat <- unlist(parcat$filter)["vars_selected"] |
| 568 | ! |
input_aval_var <- names(merged$anl_input_r()$columns_source$aval_var) |
| 569 | ! |
input_avalu_var <- names(merged$anl_input_r()$columns_source$avalu_var) |
| 570 | ||
| 571 |
# validate inputs |
|
| 572 | ! |
validate_standard_inputs( |
| 573 | ! |
adsl = adsl_filtered, |
| 574 | ! |
adslvars = c("USUBJID", "STUDYID", input_col_by_var),
|
| 575 | ! |
anl = anl_filtered, |
| 576 | ! |
anlvars = c( |
| 577 | ! |
"USUBJID", "STUDYID", input_id_var, input_paramcd, |
| 578 | ! |
input_row_by_var, input_parcat, input_aval_var, input_avalu_var |
| 579 |
), |
|
| 580 | ! |
arm_var = NULL, |
| 581 | ! |
need_arm = FALSE |
| 582 |
) |
|
| 583 | ! |
NULL |
| 584 |
}) |
|
| 585 | ||
| 586 | ! |
all_q <- reactive({
|
| 587 | ! |
validate_checks() |
| 588 | ||
| 589 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 590 | ! |
input_avalu_var <- as.character( |
| 591 | ! |
unique(merged$anl_q()[["ANL"]][[names(merged$anl_input_r()$columns_source$avalu_var)[1]]]) |
| 592 |
) |
|
| 593 | ! |
input_paramcd <- as.character( |
| 594 | ! |
unique(merged$anl_q()[["ANL"]][[names(merged$anl_input_r()$columns_source$paramcd)[1]]]) |
| 595 |
) |
|
| 596 | ||
| 597 | ! |
if (is.null(paramcd_label)) {
|
| 598 | ! |
input_paramcd_label <- input_paramcd |
| 599 |
} else {
|
|
| 600 | ! |
paramcd <- names(merged$anl_input_r()$columns_source$paramcd) |
| 601 | ! |
paramcd_map_list <- c(paramcd, paramcd_label) |
| 602 | ! |
paramcd_map <- unique(anl_filtered[paramcd_map_list]) |
| 603 | ! |
input_paramcd_label <- as.character(paramcd_map[paramcd_map[1] == input_paramcd, 2]) |
| 604 |
} |
|
| 605 | ||
| 606 | ! |
basic_table_args$title <- "Duration of Exposure Table" |
| 607 | ! |
basic_table_args$subtitles <- |
| 608 | ! |
paste("Parameter Category:", merged$anl_input_r()$filter_info$parcat[[1]]$selected[[1]])
|
| 609 | ||
| 610 | ! |
my_calls <- template_exposure( |
| 611 | ! |
parentname = "ANL_ADSL", |
| 612 | ! |
dataname = "ANL", |
| 613 | ! |
id_var = names(merged$anl_input_r()$columns_source$id_var), |
| 614 | ! |
paramcd = input_paramcd, |
| 615 | ! |
paramcd_label = input_paramcd_label, |
| 616 | ! |
row_by_var = names(merged$anl_input_r()$columns_source$row_by_var), |
| 617 | ! |
col_by_var = names(merged$anl_input_r()$columns_source$col_by_var), |
| 618 | ! |
add_total = input$add_total, |
| 619 | ! |
total_label = total_label, |
| 620 | ! |
add_total_row = input$add_total_row, |
| 621 | ! |
total_row_label = total_row_label, |
| 622 | ! |
drop_levels = TRUE, |
| 623 | ! |
na_level = na_level, |
| 624 | ! |
aval_var = names(merged$anl_input_r()$columns_source$aval_var), |
| 625 | ! |
avalu_var = input_avalu_var, |
| 626 | ! |
basic_table_args = basic_table_args |
| 627 |
) |
|
| 628 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 629 |
}) |
|
| 630 | ||
| 631 |
# Outputs to render. |
|
| 632 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 633 | ||
| 634 | ! |
teal.widgets::table_with_settings_srv( |
| 635 | ! |
id = "table", |
| 636 | ! |
table_r = table_r |
| 637 |
) |
|
| 638 | ||
| 639 |
# Render R code. |
|
| 640 | ! |
teal.widgets::verbatim_popup_srv( |
| 641 | ! |
id = "rcode", |
| 642 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 643 | ! |
title = label |
| 644 |
) |
|
| 645 | ||
| 646 |
### REPORTER |
|
| 647 | ! |
if (with_reporter) {
|
| 648 | ! |
card_fun <- function(comment, label) {
|
| 649 | ! |
card <- teal::report_card_template( |
| 650 | ! |
title = "Exposure for Risk Management Plan Table", |
| 651 | ! |
label = label, |
| 652 | ! |
with_filter = with_filter, |
| 653 | ! |
filter_panel_api = filter_panel_api |
| 654 |
) |
|
| 655 | ! |
card$append_text("Table", "header3")
|
| 656 | ! |
card$append_table(table_r()) |
| 657 | ! |
if (!comment == "") {
|
| 658 | ! |
card$append_text("Comment", "header3")
|
| 659 | ! |
card$append_text(comment) |
| 660 |
} |
|
| 661 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 662 | ! |
card |
| 663 |
} |
|
| 664 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 665 |
} |
|
| 666 |
### |
|
| 667 |
}) |
|
| 668 |
} |
| 1 |
#' Template: Kaplan-Meier Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a Kaplan-Meier plot. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @inheritParams tern::g_km |
|
| 7 |
#' @inheritParams tern::control_coxreg |
|
| 8 |
#' @param facet_var (`character`)\cr name of the variable to use to facet the plot. |
|
| 9 |
#' |
|
| 10 |
#' @inherit template_arguments return |
|
| 11 |
#' |
|
| 12 |
#' @seealso [tm_g_km()] |
|
| 13 |
#' |
|
| 14 |
#' @keywords internal |
|
| 15 |
template_g_km <- function(dataname = "ANL", |
|
| 16 |
arm_var = "ARM", |
|
| 17 |
ref_arm = NULL, |
|
| 18 |
comp_arm = NULL, |
|
| 19 |
compare_arm = FALSE, |
|
| 20 |
combine_comp_arms = FALSE, |
|
| 21 |
aval_var = "AVAL", |
|
| 22 |
cnsr_var = "CNSR", |
|
| 23 |
xticks = NULL, |
|
| 24 |
strata_var = NULL, |
|
| 25 |
time_points = NULL, |
|
| 26 |
facet_var = "SEX", |
|
| 27 |
font_size = 11, |
|
| 28 |
conf_level = 0.95, |
|
| 29 |
ties = "efron", |
|
| 30 |
xlab = "Survival time", |
|
| 31 |
time_unit_var = "AVALU", |
|
| 32 |
yval = "Survival", |
|
| 33 |
ylim = NULL, |
|
| 34 |
pval_method = "log-rank", |
|
| 35 |
annot_surv_med = TRUE, |
|
| 36 |
annot_coxph = TRUE, |
|
| 37 |
control_annot_surv_med = control_surv_med_annot(), |
|
| 38 |
control_annot_coxph = control_coxph_annot(x = 0.27, y = 0.35, w = 0.3), |
|
| 39 |
legend_pos = NULL, |
|
| 40 |
position_coxph = lifecycle::deprecated(), |
|
| 41 |
width_annots = lifecycle::deprecated(), |
|
| 42 |
rel_height_plot = 0.80, |
|
| 43 |
ci_ribbon = FALSE, |
|
| 44 |
title = "KM Plot") {
|
|
| 45 | 3x |
if (lifecycle::is_present(position_coxph)) {
|
| 46 | ! |
control_annot_coxph[["x"]] <- position_coxph[1] |
| 47 | ! |
control_annot_coxph[["y"]] <- position_coxph[2] |
| 48 | ! |
lifecycle::deprecate_warn( |
| 49 | ! |
"0.8.17", |
| 50 | ! |
"template_g_km(position_coxph)", |
| 51 | ! |
details = "Please use the 'x' and 'y' elements of the `control_annot_coxph` argument instead." |
| 52 |
) |
|
| 53 |
} |
|
| 54 | 3x |
if (lifecycle::is_present(width_annots)) {
|
| 55 | ! |
control_annot_surv_med[["w"]] <- width_annots[["surv_med"]] |
| 56 | ! |
control_annot_coxph[["w"]] <- width_annots[["coxph"]] |
| 57 | ! |
lifecycle::deprecate_warn( |
| 58 | ! |
"0.8.17", |
| 59 | ! |
"template_g_km(width_annots)", |
| 60 | ! |
details = paste( |
| 61 | ! |
"Please use the 'w' element of the `control_annot_surv_med`", |
| 62 | ! |
"and `control_annot_coxph` arguments instead." |
| 63 |
) |
|
| 64 |
) |
|
| 65 |
} |
|
| 66 | 3x |
checkmate::assert_string(dataname) |
| 67 | 3x |
checkmate::assert_string(arm_var) |
| 68 | 3x |
checkmate::assert_string(aval_var) |
| 69 | 3x |
checkmate::assert_string(cnsr_var) |
| 70 | 3x |
checkmate::assert_string(time_unit_var) |
| 71 | 3x |
checkmate::assert_flag(compare_arm) |
| 72 | 3x |
checkmate::assert_flag(combine_comp_arms) |
| 73 | 3x |
checkmate::assert_numeric(xticks, null.ok = TRUE) |
| 74 | 3x |
checkmate::assert_string(title) |
| 75 | 3x |
checkmate::assert_number(font_size) |
| 76 | 3x |
checkmate::assert_number(rel_height_plot, lower = 0, upper = 1) |
| 77 | ||
| 78 | 3x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 79 | 3x |
y <- list() |
| 80 | ||
| 81 | 3x |
data_list <- list() |
| 82 | 3x |
data_list <- add_expr( |
| 83 | 3x |
data_list, |
| 84 | 3x |
prepare_arm( |
| 85 | 3x |
dataname = dataname, |
| 86 | 3x |
arm_var = arm_var, |
| 87 | 3x |
ref_arm = ref_arm, |
| 88 | 3x |
comp_arm = comp_arm, |
| 89 | 3x |
compare_arm = compare_arm, |
| 90 | 3x |
ref_arm_val = ref_arm_val |
| 91 |
) |
|
| 92 |
) |
|
| 93 | ||
| 94 | 3x |
data_list <- add_expr( |
| 95 | 3x |
data_list, |
| 96 | 3x |
substitute( |
| 97 | 3x |
expr = dplyr::mutate( |
| 98 | 3x |
is_event = cnsr_var == 0 |
| 99 |
), |
|
| 100 | 3x |
env = list( |
| 101 | 3x |
anl = as.name(dataname), |
| 102 | 3x |
cnsr_var = as.name(cnsr_var) |
| 103 |
) |
|
| 104 |
) |
|
| 105 |
) |
|
| 106 | ||
| 107 | 3x |
if (compare_arm && combine_comp_arms) {
|
| 108 | 1x |
comp_arm_val <- paste(comp_arm, collapse = "/") |
| 109 | 1x |
data_list <- add_expr( |
| 110 | 1x |
data_list, |
| 111 | 1x |
substitute_names( |
| 112 | 1x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = comp_arm, new_level = comp_arm_val)), |
| 113 | 1x |
names = list(arm_var = as.name(arm_var)), |
| 114 | 1x |
others = list(comp_arm = comp_arm, comp_arm_val = comp_arm_val) |
| 115 |
) |
|
| 116 |
) |
|
| 117 |
} |
|
| 118 | ||
| 119 | 3x |
y$data <- substitute( |
| 120 | 3x |
expr = {
|
| 121 | ! |
anl <- data_pipe |
| 122 |
}, |
|
| 123 | 3x |
env = list( |
| 124 | 3x |
data_pipe = pipe_expr(data_list) |
| 125 |
) |
|
| 126 |
) |
|
| 127 | ||
| 128 | 3x |
y$variables <- if (length(strata_var) != 0) {
|
| 129 | ! |
substitute( |
| 130 | ! |
expr = variables <- list(tte = tte, is_event = "is_event", arm = arm, strata = strata_var), |
| 131 | ! |
env = list(tte = aval_var, arm = arm_var, strata_var = strata_var) |
| 132 |
) |
|
| 133 |
} else {
|
|
| 134 | 3x |
substitute( |
| 135 | 3x |
expr = variables <- list(tte = tte, is_event = "is_event", arm = arm), |
| 136 | 3x |
env = list(tte = aval_var, arm = arm_var) |
| 137 |
) |
|
| 138 |
} |
|
| 139 | 3x |
graph_list <- list() |
| 140 | ||
| 141 | 3x |
if (length(facet_var) != 0L) {
|
| 142 | 3x |
graph_list <- add_expr( |
| 143 | 3x |
graph_list, |
| 144 | 3x |
substitute( |
| 145 | 3x |
expr = {
|
| 146 | ! |
facets <- droplevels(anl$facet_var) |
| 147 | ! |
anl <- split(anl, f = facets) |
| 148 |
}, |
|
| 149 | 3x |
env = list( |
| 150 | 3x |
facet_var = as.name(facet_var) |
| 151 |
) |
|
| 152 |
) |
|
| 153 |
) |
|
| 154 |
} else {
|
|
| 155 | ! |
graph_list <- add_expr( |
| 156 | ! |
graph_list, |
| 157 | ! |
substitute( |
| 158 | ! |
expr = {
|
| 159 | ! |
facets <- NULL |
| 160 | ! |
anl <- list(anl) |
| 161 |
} |
|
| 162 |
) |
|
| 163 |
) |
|
| 164 |
} |
|
| 165 | ||
| 166 | 3x |
graph_list <- add_expr( |
| 167 | 3x |
graph_list, |
| 168 | 3x |
substitute( |
| 169 | 3x |
expr = {
|
| 170 | ! |
g_km_counter_generator <- function() {
|
| 171 | ! |
plot_number <- 0L |
| 172 | ! |
function(x) {
|
| 173 | ! |
plot_number <<- plot_number + 1L |
| 174 | ! |
g_km( |
| 175 | ! |
x, |
| 176 | ! |
variables = variables, |
| 177 | ! |
control_surv = control_surv_timepoint(conf_level = conf_level), |
| 178 | ! |
xticks = xticks, |
| 179 | ! |
xlab = sprintf( |
| 180 | ! |
"%s (%s)", |
| 181 | ! |
xlab, |
| 182 | ! |
gsub("(^|[[:space:]])([[:alpha:]])", "\\1\\U\\2", tolower(x$time_unit_var[1]), perl = TRUE)
|
| 183 |
), |
|
| 184 | ! |
yval = yval, |
| 185 | ! |
ylim = ylim, |
| 186 | ! |
title = sprintf( |
| 187 | ! |
"%s%s", |
| 188 | ! |
sprintf( |
| 189 | ! |
"%s%s", |
| 190 | ! |
title, |
| 191 | ! |
if (!is.null(facets)) {
|
| 192 | ! |
sprintf(", %s = %s", as.character(quote(facet_var)), unique(x[[as.character(quote(facet_var))]]))
|
| 193 |
} else {
|
|
| 194 |
"" |
|
| 195 |
} |
|
| 196 |
), |
|
| 197 | ! |
if (length(strata_var) != 0) {
|
| 198 | ! |
sprintf("\nStratified by %s", toString(strata_var))
|
| 199 |
} else {
|
|
| 200 |
"" |
|
| 201 |
} |
|
| 202 |
), |
|
| 203 | ! |
footnotes = if (annot_coxph) {
|
| 204 | ! |
paste( |
| 205 | ! |
"Ties for Coxph (Hazard Ratio):", ties, "\n", |
| 206 | ! |
"p-value Method for Coxph (Hazard Ratio):", pval_method |
| 207 |
) |
|
| 208 |
}, |
|
| 209 | ! |
font_size = font_size, |
| 210 | ! |
ci_ribbon = ci_ribbon, |
| 211 | ! |
annot_surv_med = annot_surv_med, |
| 212 | ! |
annot_coxph = annot_coxph, |
| 213 | ! |
control_coxph_pw = control_coxph(conf_level = conf_level, pval_method = pval_method, ties = ties), |
| 214 | ! |
control_annot_surv_med = control_annot_surv_med, |
| 215 | ! |
control_annot_coxph = control_annot_coxph, |
| 216 | ! |
legend_pos = legend_pos, |
| 217 | ! |
rel_height_plot = rel_height_plot |
| 218 |
) |
|
| 219 |
} |
|
| 220 |
} |
|
| 221 | ||
| 222 | ! |
g_km_counter <- g_km_counter_generator() |
| 223 | ||
| 224 | ! |
plot_list <- lapply( |
| 225 | ! |
anl, |
| 226 | ! |
g_km_counter |
| 227 |
) |
|
| 228 | ||
| 229 | ! |
plot <- cowplot::plot_grid( |
| 230 | ! |
plotlist = plot_list, |
| 231 | ! |
ncol = 1 |
| 232 |
) |
|
| 233 | ! |
plot |
| 234 |
}, |
|
| 235 | 3x |
env = list( |
| 236 | 3x |
facet_var = if (length(facet_var) != 0L) as.name(facet_var), |
| 237 | 3x |
font_size = font_size, |
| 238 | 3x |
strata_var = strata_var, |
| 239 | 3x |
xticks = xticks, |
| 240 | 3x |
xlab = xlab, |
| 241 | 3x |
time_unit_var = as.name(time_unit_var), |
| 242 | 3x |
yval = yval, |
| 243 | 3x |
ylim = ylim, |
| 244 | 3x |
conf_level = conf_level, |
| 245 | 3x |
pval_method = pval_method, |
| 246 | 3x |
annot_surv_med = annot_surv_med, |
| 247 | 3x |
annot_coxph = annot_coxph, |
| 248 | 3x |
control_annot_surv_med = control_annot_surv_med, |
| 249 | 3x |
control_annot_coxph = control_annot_coxph, |
| 250 | 3x |
legend_pos = legend_pos, |
| 251 | 3x |
ties = ties, |
| 252 | 3x |
ci_ribbon = ci_ribbon, |
| 253 | 3x |
rel_height_plot = rel_height_plot, |
| 254 | 3x |
title = title |
| 255 |
) |
|
| 256 |
) |
|
| 257 |
) |
|
| 258 | ||
| 259 | 3x |
y$graph <- bracket_expr(graph_list) |
| 260 | 3x |
y |
| 261 |
} |
|
| 262 | ||
| 263 |
#' teal Module: Kaplan-Meier Plot |
|
| 264 |
#' |
|
| 265 |
#' This module produces a `ggplot`-style Kaplan-Meier plot for data with ADaM structure. |
|
| 266 |
#' |
|
| 267 |
#' @inheritParams module_arguments |
|
| 268 |
#' @inheritParams template_g_km |
|
| 269 |
#' @param facet_var ([teal.transform::choices_selected()])\cr object with |
|
| 270 |
#' all available choices and preselected option for names of variable that can be used for plot faceting. |
|
| 271 |
#' |
|
| 272 |
#' @inherit module_arguments return seealso |
|
| 273 |
#' |
|
| 274 |
#' @examples |
|
| 275 |
#' library(nestcolor) |
|
| 276 |
#' |
|
| 277 |
#' ADSL <- tmc_ex_adsl |
|
| 278 |
#' ADTTE <- tmc_ex_adtte |
|
| 279 |
#' |
|
| 280 |
#' arm_ref_comp <- list( |
|
| 281 |
#' ACTARMCD = list( |
|
| 282 |
#' ref = "ARM B", |
|
| 283 |
#' comp = c("ARM A", "ARM C")
|
|
| 284 |
#' ), |
|
| 285 |
#' ARM = list( |
|
| 286 |
#' ref = "B: Placebo", |
|
| 287 |
#' comp = c("A: Drug X", "C: Combination")
|
|
| 288 |
#' ) |
|
| 289 |
#' ) |
|
| 290 |
#' |
|
| 291 |
#' app <- init( |
|
| 292 |
#' data = cdisc_data( |
|
| 293 |
#' ADSL = ADSL, |
|
| 294 |
#' ADTTE = ADTTE, |
|
| 295 |
#' code = " |
|
| 296 |
#' ADSL <- tmc_ex_adsl |
|
| 297 |
#' ADTTE <- tmc_ex_adtte |
|
| 298 |
#' " |
|
| 299 |
#' ), |
|
| 300 |
#' modules = modules( |
|
| 301 |
#' tm_g_km( |
|
| 302 |
#' label = "Kaplan-Meier Plot", |
|
| 303 |
#' dataname = "ADTTE", |
|
| 304 |
#' arm_var = choices_selected( |
|
| 305 |
#' variable_choices(ADSL, c("ARM", "ARMCD", "ACTARMCD")),
|
|
| 306 |
#' "ARM" |
|
| 307 |
#' ), |
|
| 308 |
#' paramcd = choices_selected( |
|
| 309 |
#' value_choices(ADTTE, "PARAMCD", "PARAM"), |
|
| 310 |
#' "OS" |
|
| 311 |
#' ), |
|
| 312 |
#' arm_ref_comp = arm_ref_comp, |
|
| 313 |
#' strata_var = choices_selected( |
|
| 314 |
#' variable_choices(ADSL, c("SEX", "BMRKR2")),
|
|
| 315 |
#' "SEX" |
|
| 316 |
#' ), |
|
| 317 |
#' facet_var = choices_selected( |
|
| 318 |
#' variable_choices(ADSL, c("SEX", "BMRKR2")),
|
|
| 319 |
#' NULL |
|
| 320 |
#' ) |
|
| 321 |
#' ) |
|
| 322 |
#' ) |
|
| 323 |
#' ) |
|
| 324 |
#' if (interactive()) {
|
|
| 325 |
#' shinyApp(app$ui, app$server) |
|
| 326 |
#' } |
|
| 327 |
#' |
|
| 328 |
#' @export |
|
| 329 |
tm_g_km <- function(label, |
|
| 330 |
dataname, |
|
| 331 |
parentname = ifelse( |
|
| 332 |
inherits(arm_var, "data_extract_spec"), |
|
| 333 |
teal.transform::datanames_input(arm_var), |
|
| 334 |
"ADSL" |
|
| 335 |
), |
|
| 336 |
arm_var, |
|
| 337 |
arm_ref_comp = NULL, |
|
| 338 |
paramcd, |
|
| 339 |
strata_var, |
|
| 340 |
facet_var, |
|
| 341 |
time_unit_var = teal.transform::choices_selected( |
|
| 342 |
teal.transform::variable_choices(dataname, "AVALU"), "AVALU", |
|
| 343 |
fixed = TRUE |
|
| 344 |
), |
|
| 345 |
aval_var = teal.transform::choices_selected( |
|
| 346 |
teal.transform::variable_choices(dataname, "AVAL"), "AVAL", |
|
| 347 |
fixed = TRUE |
|
| 348 |
), |
|
| 349 |
cnsr_var = teal.transform::choices_selected( |
|
| 350 |
teal.transform::variable_choices(dataname, "CNSR"), "CNSR", |
|
| 351 |
fixed = TRUE |
|
| 352 |
), |
|
| 353 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 354 |
font_size = c(11L, 1L, 30), |
|
| 355 |
control_annot_surv_med = control_surv_med_annot(), |
|
| 356 |
control_annot_coxph = control_coxph_annot(x = 0.27, y = 0.35, w = 0.3), |
|
| 357 |
legend_pos = c(0.9, 0.5), |
|
| 358 |
rel_height_plot = c(80L, 0L, 100L), |
|
| 359 |
plot_height = c(800L, 400L, 5000L), |
|
| 360 |
plot_width = NULL, |
|
| 361 |
pre_output = NULL, |
|
| 362 |
post_output = NULL) {
|
|
| 363 | ! |
message("Initializing tm_g_km")
|
| 364 | ||
| 365 | ! |
checkmate::assert_string(label) |
| 366 | ! |
checkmate::assert_string(dataname) |
| 367 | ! |
checkmate::assert_string(parentname) |
| 368 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 369 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 370 | ! |
checkmate::assert_class(strata_var, "choices_selected") |
| 371 | ! |
checkmate::assert_class(facet_var, "choices_selected") |
| 372 | ! |
checkmate::assert_class(time_unit_var, "choices_selected") |
| 373 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 374 | ! |
checkmate::assert_class(cnsr_var, "choices_selected") |
| 375 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 376 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 377 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 378 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 379 | ! |
checkmate::assert_numeric( |
| 380 | ! |
plot_width[1], |
| 381 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 382 |
) |
|
| 383 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 384 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 385 | ||
| 386 | ! |
args <- as.list(environment()) |
| 387 | ! |
data_extract_list <- list( |
| 388 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 389 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 390 | ! |
strata_var = cs_to_des_select(strata_var, dataname = parentname, multiple = TRUE), |
| 391 | ! |
facet_var = cs_to_des_select(facet_var, dataname = parentname, multiple = FALSE), |
| 392 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 393 | ! |
cnsr_var = cs_to_des_select(cnsr_var, dataname = dataname), |
| 394 | ! |
time_unit_var = cs_to_des_select(time_unit_var, dataname = dataname) |
| 395 |
) |
|
| 396 | ||
| 397 | ! |
module( |
| 398 | ! |
label = label, |
| 399 | ! |
server = srv_g_km, |
| 400 | ! |
ui = ui_g_km, |
| 401 | ! |
ui_args = c(data_extract_list, args), |
| 402 | ! |
server_args = c( |
| 403 | ! |
data_extract_list, |
| 404 | ! |
list( |
| 405 | ! |
dataname = dataname, |
| 406 | ! |
label = label, |
| 407 | ! |
parentname = parentname, |
| 408 | ! |
arm_ref_comp = arm_ref_comp, |
| 409 | ! |
plot_height = plot_height, |
| 410 | ! |
plot_width = plot_width, |
| 411 | ! |
control_annot_surv_med = control_annot_surv_med, |
| 412 | ! |
control_annot_coxph = control_annot_coxph, |
| 413 | ! |
legend_pos = legend_pos |
| 414 |
) |
|
| 415 |
), |
|
| 416 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 417 |
) |
|
| 418 |
} |
|
| 419 | ||
| 420 |
#' @keywords internal |
|
| 421 |
ui_g_km <- function(id, ...) {
|
|
| 422 | ! |
a <- list(...) |
| 423 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 424 | ! |
a$arm_var, |
| 425 | ! |
a$paramcd, |
| 426 | ! |
a$strata_var, |
| 427 | ! |
a$facet_var, |
| 428 | ! |
a$aval_var, |
| 429 | ! |
a$cnsr_var, |
| 430 | ! |
a$time_unit_var |
| 431 |
) |
|
| 432 | ||
| 433 | ! |
ns <- NS(id) |
| 434 | ||
| 435 | ! |
teal.widgets::standard_layout( |
| 436 | ! |
output = teal.widgets::white_small_well( |
| 437 | ! |
verbatimTextOutput(outputId = ns("text")),
|
| 438 | ! |
teal.widgets::plot_with_settings_ui( |
| 439 | ! |
id = ns("myplot")
|
| 440 |
) |
|
| 441 |
), |
|
| 442 | ! |
encoding = tags$div( |
| 443 |
### Reporter |
|
| 444 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 445 |
### |
|
| 446 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 447 | ! |
teal.transform::datanames_input(a[c("arm_var", "paramcd", "strata_var", "facet_var", "aval_var", "cnsr_var")]),
|
| 448 | ! |
teal.transform::data_extract_ui( |
| 449 | ! |
id = ns("paramcd"),
|
| 450 | ! |
label = "Select Endpoint", |
| 451 | ! |
data_extract_spec = a$paramcd, |
| 452 | ! |
is_single_dataset = is_single_dataset_value |
| 453 |
), |
|
| 454 | ! |
teal.transform::data_extract_ui( |
| 455 | ! |
id = ns("aval_var"),
|
| 456 | ! |
label = "Analysis Variable", |
| 457 | ! |
data_extract_spec = a$aval_var, |
| 458 | ! |
is_single_dataset = is_single_dataset_value |
| 459 |
), |
|
| 460 | ! |
teal.transform::data_extract_ui( |
| 461 | ! |
id = ns("cnsr_var"),
|
| 462 | ! |
label = "Censor Variable", |
| 463 | ! |
data_extract_spec = a$cnsr_var, |
| 464 | ! |
is_single_dataset = is_single_dataset_value |
| 465 |
), |
|
| 466 | ! |
teal.transform::data_extract_ui( |
| 467 | ! |
id = ns("facet_var"),
|
| 468 | ! |
label = "Facet Plots by", |
| 469 | ! |
data_extract_spec = a$facet_var, |
| 470 | ! |
is_single_dataset = is_single_dataset_value |
| 471 |
), |
|
| 472 | ! |
teal.transform::data_extract_ui( |
| 473 | ! |
id = ns("arm_var"),
|
| 474 | ! |
label = "Select Treatment Variable", |
| 475 | ! |
data_extract_spec = a$arm_var, |
| 476 | ! |
is_single_dataset = is_single_dataset_value |
| 477 |
), |
|
| 478 | ! |
tags$div( |
| 479 | ! |
class = "arm-comp-box", |
| 480 | ! |
tags$label("Compare Treatments"),
|
| 481 | ! |
shinyWidgets::switchInput( |
| 482 | ! |
inputId = ns("compare_arms"),
|
| 483 | ! |
value = !is.null(a$arm_ref_comp), |
| 484 | ! |
size = "mini" |
| 485 |
), |
|
| 486 | ! |
conditionalPanel( |
| 487 | ! |
condition = paste0("input['", ns("compare_arms"), "']"),
|
| 488 | ! |
tags$div( |
| 489 | ! |
uiOutput( |
| 490 | ! |
ns("arms_buckets"),
|
| 491 | ! |
title = paste( |
| 492 | ! |
"Multiple reference groups are automatically combined into a single group when more than one", |
| 493 | ! |
"value is selected." |
| 494 |
) |
|
| 495 |
), |
|
| 496 | ! |
checkboxInput( |
| 497 | ! |
ns("combine_comp_arms"),
|
| 498 | ! |
"Combine all comparison groups?", |
| 499 | ! |
value = FALSE |
| 500 |
), |
|
| 501 | ! |
teal.transform::data_extract_ui( |
| 502 | ! |
id = ns("strata_var"),
|
| 503 | ! |
label = "Stratify by", |
| 504 | ! |
data_extract_spec = a$strata_var, |
| 505 | ! |
is_single_dataset = is_single_dataset_value |
| 506 |
) |
|
| 507 |
) |
|
| 508 |
) |
|
| 509 |
), |
|
| 510 | ! |
conditionalPanel( |
| 511 | ! |
condition = paste0("input['", ns("compare_arms"), "']"),
|
| 512 | ! |
teal.widgets::panel_group( |
| 513 | ! |
teal.widgets::panel_item( |
| 514 | ! |
"Comparison settings", |
| 515 | ! |
radioButtons( |
| 516 | ! |
ns("pval_method_coxph"),
|
| 517 | ! |
label = HTML( |
| 518 | ! |
paste( |
| 519 | ! |
"p-value method for ", |
| 520 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 521 | ! |
" (Hazard Ratio)", |
| 522 | ! |
sep = "" |
| 523 |
) |
|
| 524 |
), |
|
| 525 | ! |
choices = c("wald", "log-rank", "likelihood"),
|
| 526 | ! |
selected = "log-rank" |
| 527 |
), |
|
| 528 | ! |
radioButtons( |
| 529 | ! |
ns("ties_coxph"),
|
| 530 | ! |
label = HTML( |
| 531 | ! |
paste( |
| 532 | ! |
"Ties for ", |
| 533 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 534 | ! |
" (Hazard Ratio)", |
| 535 | ! |
sep = "" |
| 536 |
) |
|
| 537 |
), |
|
| 538 | ! |
choices = c("exact", "breslow", "efron"),
|
| 539 | ! |
selected = "exact" |
| 540 |
) |
|
| 541 |
) |
|
| 542 |
) |
|
| 543 |
), |
|
| 544 | ! |
teal.widgets::panel_group( |
| 545 | ! |
teal.widgets::panel_item( |
| 546 | ! |
"Additional plot settings", |
| 547 | ! |
textInput( |
| 548 | ! |
inputId = ns("xticks"),
|
| 549 | ! |
label = "Specify break intervals for x-axis e.g. 0 ; 500" |
| 550 |
), |
|
| 551 | ! |
radioButtons( |
| 552 | ! |
ns("yval"),
|
| 553 | ! |
tags$label("Value on y-axis", class = "text-primary"),
|
| 554 | ! |
choices = c("Survival probability", "Failure probability"),
|
| 555 | ! |
selected = c("Survival probability"),
|
| 556 |
), |
|
| 557 | ! |
teal.widgets::optionalSliderInput( |
| 558 | ! |
ns("ylim"),
|
| 559 | ! |
tags$label("y-axis limits", class = "text-primary"),
|
| 560 | ! |
value = c(0, 1), |
| 561 | ! |
min = 0, max = 1 |
| 562 |
), |
|
| 563 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 564 | ! |
ns("font_size"),
|
| 565 | ! |
"Table Font Size", |
| 566 | ! |
a$font_size, |
| 567 | ! |
ticks = FALSE, step = 1 |
| 568 |
), |
|
| 569 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 570 | ! |
ns("rel_height_plot"),
|
| 571 | ! |
"Relative Height of Plot (%)", |
| 572 | ! |
a$rel_height_plot, |
| 573 | ! |
ticks = FALSE, step = 1 |
| 574 |
), |
|
| 575 | ! |
checkboxInput( |
| 576 | ! |
inputId = ns("show_ci_ribbon"),
|
| 577 | ! |
label = "Show CI ribbon", |
| 578 | ! |
value = FALSE, |
| 579 | ! |
width = "100%" |
| 580 |
), |
|
| 581 | ! |
checkboxInput( |
| 582 | ! |
inputId = ns("show_km_table"),
|
| 583 | ! |
label = "Show KM table", |
| 584 | ! |
value = TRUE, |
| 585 | ! |
width = "100%" |
| 586 |
), |
|
| 587 | ! |
teal.widgets::optionalSelectInput( |
| 588 | ! |
ns("conf_level"),
|
| 589 | ! |
"Level of Confidence", |
| 590 | ! |
a$conf_level$choices, |
| 591 | ! |
a$conf_level$selected, |
| 592 | ! |
multiple = FALSE, |
| 593 | ! |
fixed = a$conf_level$fixed |
| 594 |
), |
|
| 595 | ! |
textInput(ns("xlab"), "X-axis label", "Time"),
|
| 596 | ! |
teal.transform::data_extract_ui( |
| 597 | ! |
id = ns("time_unit_var"),
|
| 598 | ! |
label = "Time Unit Variable", |
| 599 | ! |
data_extract_spec = a$time_unit_var, |
| 600 | ! |
is_single_dataset = is_single_dataset_value |
| 601 |
) |
|
| 602 |
) |
|
| 603 |
) |
|
| 604 |
), |
|
| 605 | ! |
forms = tagList( |
| 606 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 607 |
), |
|
| 608 | ! |
pre_output = a$pre_output, |
| 609 | ! |
post_output = a$post_output |
| 610 |
) |
|
| 611 |
} |
|
| 612 | ||
| 613 |
#' @keywords internal |
|
| 614 |
srv_g_km <- function(id, |
|
| 615 |
data, |
|
| 616 |
reporter, |
|
| 617 |
filter_panel_api, |
|
| 618 |
dataname, |
|
| 619 |
parentname, |
|
| 620 |
paramcd, |
|
| 621 |
arm_var, |
|
| 622 |
arm_ref_comp, |
|
| 623 |
strata_var, |
|
| 624 |
facet_var, |
|
| 625 |
aval_var, |
|
| 626 |
cnsr_var, |
|
| 627 |
label, |
|
| 628 |
time_unit_var, |
|
| 629 |
plot_height, |
|
| 630 |
plot_width, |
|
| 631 |
control_annot_surv_med, |
|
| 632 |
control_annot_coxph, |
|
| 633 |
legend_pos) {
|
|
| 634 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 635 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 636 | ! |
checkmate::assert_class(data, "reactive") |
| 637 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 638 | ||
| 639 | ! |
moduleServer(id, function(input, output, session) {
|
| 640 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 641 |
# Setup arm variable selection, default reference arms and default |
|
| 642 |
# comparison arms for encoding panel |
|
| 643 | ! |
iv_arm_ref <- arm_ref_comp_observer( |
| 644 | ! |
session, |
| 645 | ! |
input, |
| 646 | ! |
output, |
| 647 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 648 | ! |
data = data()[[parentname]], |
| 649 | ! |
arm_ref_comp = arm_ref_comp, |
| 650 | ! |
module = "tm_t_tte", |
| 651 | ! |
on_off = reactive(input$compare_arms) |
| 652 |
) |
|
| 653 | ||
| 654 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 655 | ! |
data_extract = list( |
| 656 | ! |
aval_var = aval_var, |
| 657 | ! |
cnsr_var = cnsr_var, |
| 658 | ! |
arm_var = arm_var, |
| 659 | ! |
paramcd = paramcd, |
| 660 | ! |
strata_var = strata_var, |
| 661 | ! |
facet_var = facet_var, |
| 662 | ! |
time_unit_var = time_unit_var |
| 663 |
), |
|
| 664 | ! |
datasets = data, |
| 665 | ! |
select_validation_rule = list( |
| 666 | ! |
aval_var = shinyvalidate::sv_required("An analysis variable is required"),
|
| 667 | ! |
cnsr_var = shinyvalidate::sv_required("A censor variable is required"),
|
| 668 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required")
|
| 669 |
), |
|
| 670 | ! |
filter_validation_rule = list( |
| 671 | ! |
paramcd = shinyvalidate::sv_required("An endpoint is required")
|
| 672 |
) |
|
| 673 |
) |
|
| 674 | ||
| 675 | ! |
iv_r <- reactive({
|
| 676 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 677 | ||
| 678 | ! |
if (isTRUE(input$compare_arms)) {
|
| 679 | ! |
iv$add_validator(iv_arm_ref) |
| 680 |
} |
|
| 681 | ||
| 682 | ! |
iv$add_rule("font_size", shinyvalidate::sv_required("Plot tables font size must be greater than or equal to 5"))
|
| 683 | ! |
iv$add_rule("font_size", shinyvalidate::sv_gte(5, "Plot tables font size must be greater than or equal to 5"))
|
| 684 | ! |
iv$add_rule("ylim", shinyvalidate::sv_required("Please choose a range for y-axis limits"))
|
| 685 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level"))
|
| 686 | ! |
iv$add_rule( |
| 687 | ! |
"conf_level", |
| 688 | ! |
shinyvalidate::sv_between( |
| 689 | ! |
0, 1, |
| 690 | ! |
inclusive = c(FALSE, FALSE), |
| 691 | ! |
message_fmt = "Confidence level must be between 0 and 1" |
| 692 |
) |
|
| 693 |
) |
|
| 694 | ! |
iv$add_rule("xticks", shinyvalidate::sv_optional())
|
| 695 | ! |
iv$add_rule( |
| 696 | ! |
"xticks", |
| 697 | ! |
function(value) {
|
| 698 | ! |
val <- as_numeric_from_comma_sep_str(value, sep = ";") |
| 699 | ! |
if (anyNA(val) || any(val < 0)) {
|
| 700 | ! |
"All break intervals for x-axis must be non-negative numbers separated by semicolons" |
| 701 | ! |
} else if (all(val == 0)) {
|
| 702 | ! |
"At least one break interval for x-axis must be > 0" |
| 703 |
} |
|
| 704 |
} |
|
| 705 |
) |
|
| 706 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 707 |
}) |
|
| 708 | ||
| 709 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 710 | ! |
datasets = data, |
| 711 | ! |
selector_list = selector_list, |
| 712 | ! |
merge_function = "dplyr::inner_join" |
| 713 |
) |
|
| 714 | ||
| 715 | ! |
anl_q <- reactive({
|
| 716 | ! |
data() %>% |
| 717 | ! |
teal.code::eval_code(code = as.expression(anl_inputs()$expr)) |
| 718 |
}) |
|
| 719 | ||
| 720 | ! |
validate_checks <- reactive({
|
| 721 | ! |
teal::validate_inputs(iv_r()) |
| 722 | ||
| 723 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 724 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 725 | ||
| 726 | ! |
anl_m <- anl_inputs() |
| 727 | ! |
input_arm_var <- as.vector(anl_m$columns_source$arm_var) |
| 728 | ! |
input_strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 729 | ! |
input_facet_var <- as.vector(anl_m$columns_source$facet_var) |
| 730 | ! |
input_aval_var <- as.vector(anl_m$columns_source$aval_var) |
| 731 | ! |
input_cnsr_var <- as.vector(anl_m$columns_source$cnsr_var) |
| 732 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 733 | ! |
input_time_unit_var <- as.vector(anl_m$columns_source$time_unit_var) |
| 734 | ||
| 735 |
# validate inputs |
|
| 736 | ! |
validate_args <- list( |
| 737 | ! |
adsl = adsl_filtered, |
| 738 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var, input_strata_var, input_facet_var),
|
| 739 | ! |
anl = anl_filtered, |
| 740 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_aval_var, input_cnsr_var, input_time_unit_var),
|
| 741 | ! |
arm_var = input_arm_var |
| 742 |
) |
|
| 743 | ||
| 744 |
# validate arm levels |
|
| 745 | ! |
if (length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) == 1) {
|
| 746 | ! |
validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) |
| 747 |
} |
|
| 748 | ! |
if (isTRUE(input$compare_arms)) {
|
| 749 | ! |
validate_args <- append( |
| 750 | ! |
validate_args, |
| 751 | ! |
list(ref_arm = unlist(input$buckets$Ref), comp_arm = unlist(input$buckets$Comp)) |
| 752 |
) |
|
| 753 |
} |
|
| 754 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 755 | ||
| 756 | ! |
NULL |
| 757 |
}) |
|
| 758 | ||
| 759 | ! |
all_q <- reactive({
|
| 760 | ! |
validate_checks() |
| 761 | ||
| 762 | ! |
anl_m <- anl_inputs() |
| 763 | ||
| 764 | ! |
anl <- anl_q()[["ANL"]] |
| 765 | ! |
teal::validate_has_data(anl, 2) |
| 766 | ||
| 767 | ! |
input_xticks <- if (!is.null(input$xticks)) {
|
| 768 | ! |
as_numeric_from_comma_sep_str(input$xticks, sep = ";") |
| 769 |
} |
|
| 770 | ||
| 771 | ! |
input_paramcd <- as.character(unique(anl[[as.vector(anl_m$columns_source$paramcd)]])) |
| 772 | ! |
title <- paste("KM Plot of", input_paramcd)
|
| 773 | ||
| 774 | ! |
my_calls <- template_g_km( |
| 775 | ! |
dataname = "ANL", |
| 776 | ! |
arm_var = as.vector(anl_m$columns_source$arm_var), |
| 777 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 778 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 779 | ! |
compare_arm = input$compare_arms, |
| 780 | ! |
combine_comp_arms = input$combine_comp_arms, |
| 781 | ! |
aval_var = as.vector(anl_m$columns_source$aval_var), |
| 782 | ! |
cnsr_var = as.vector(anl_m$columns_source$cnsr_var), |
| 783 | ! |
strata_var = as.vector(anl_m$columns_source$strata_var), |
| 784 | ! |
time_points = NULL, |
| 785 | ! |
time_unit_var = as.vector(anl_m$columns_source$time_unit_var), |
| 786 | ! |
facet_var = as.vector(anl_m$columns_source$facet_var), |
| 787 | ! |
annot_surv_med = input$show_km_table, |
| 788 | ! |
annot_coxph = input$compare_arms, |
| 789 | ! |
control_annot_surv_med = control_annot_surv_med, |
| 790 | ! |
control_annot_coxph = control_annot_coxph, |
| 791 | ! |
legend_pos = legend_pos, |
| 792 | ! |
xticks = input_xticks, |
| 793 | ! |
font_size = input$font_size, |
| 794 | ! |
pval_method = input$pval_method_coxph, |
| 795 | ! |
conf_level = as.numeric(input$conf_level), |
| 796 | ! |
ties = input$ties_coxph, |
| 797 | ! |
xlab = input$xlab, |
| 798 | ! |
yval = ifelse(input$yval == "Survival probability", "Survival", "Failure"), |
| 799 | ! |
ylim = input$ylim, |
| 800 | ! |
rel_height_plot = input$rel_height_plot / 100, |
| 801 | ! |
ci_ribbon = input$show_ci_ribbon, |
| 802 | ! |
title = title |
| 803 |
) |
|
| 804 | ! |
teal.code::eval_code(anl_q(), as.expression(my_calls)) |
| 805 |
}) |
|
| 806 | ||
| 807 | ! |
plot_r <- reactive(all_q()[["plot"]]) |
| 808 | ||
| 809 |
# Insert the plot into a plot with settings module from teal.widgets |
|
| 810 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 811 | ! |
id = "myplot", |
| 812 | ! |
plot_r = plot_r, |
| 813 | ! |
height = plot_height, |
| 814 | ! |
width = plot_width |
| 815 |
) |
|
| 816 | ||
| 817 | ! |
teal.widgets::verbatim_popup_srv( |
| 818 | ! |
id = "rcode", |
| 819 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 820 | ! |
title = label |
| 821 |
) |
|
| 822 | ||
| 823 |
### REPORTER |
|
| 824 | ! |
if (with_reporter) {
|
| 825 | ! |
card_fun <- function(comment, label) {
|
| 826 | ! |
card <- teal::report_card_template( |
| 827 | ! |
title = "Kaplan Meier Plot", |
| 828 | ! |
label = label, |
| 829 | ! |
description = "Non-parametric method used to estimate the survival function from lifetime data", |
| 830 | ! |
with_filter = with_filter, |
| 831 | ! |
filter_panel_api = filter_panel_api |
| 832 |
) |
|
| 833 | ! |
card$append_text("Plot", "header3")
|
| 834 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 835 | ! |
if (!comment == "") {
|
| 836 | ! |
card$append_text("Comment", "header3")
|
| 837 | ! |
card$append_text(comment) |
| 838 |
} |
|
| 839 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 840 | ! |
card |
| 841 |
} |
|
| 842 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 843 |
} |
|
| 844 |
### |
|
| 845 |
}) |
|
| 846 |
} |
| 1 |
#' Template: Events by Grade |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table to summarize events by grade. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param id (`character`)\cr unique identifier of patients in datasets, default to `"USUBJID"`. |
|
| 7 |
#' @param grade (`character`)\cr name of the severity level variable. |
|
| 8 |
#' @param label_grade (`string`)\cr label of the `grade` variable from `dataname`. The label will be extracted from the |
|
| 9 |
#' module. |
|
| 10 |
#' |
|
| 11 |
#' @inherit template_arguments return |
|
| 12 |
#' |
|
| 13 |
#' @seealso [tm_t_events_by_grade()] |
|
| 14 |
#' |
|
| 15 |
#' @keywords internal |
|
| 16 |
template_events_by_grade <- function(dataname, |
|
| 17 |
parentname, |
|
| 18 |
arm_var, |
|
| 19 |
id = "", |
|
| 20 |
hlt, |
|
| 21 |
llt, |
|
| 22 |
label_hlt = NULL, |
|
| 23 |
label_llt = NULL, |
|
| 24 |
grade, |
|
| 25 |
label_grade = NULL, |
|
| 26 |
prune_freq = 0, |
|
| 27 |
prune_diff = 0, |
|
| 28 |
add_total = TRUE, |
|
| 29 |
total_label = default_total_label(), |
|
| 30 |
na_level = default_na_str(), |
|
| 31 |
drop_arm_levels = TRUE, |
|
| 32 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 33 | 4x |
checkmate::assert_string(dataname) |
| 34 | 4x |
checkmate::assert_string(parentname) |
| 35 | 4x |
checkmate::assert_string(arm_var) |
| 36 | 4x |
checkmate::assert_string(hlt, null.ok = TRUE) |
| 37 | 4x |
checkmate::assert_string(llt, null.ok = TRUE) |
| 38 | ! |
if (is.null(hlt) && is.null(llt)) stop("At least one of 'hlt' or 'llt' can not be empty.")
|
| 39 | 4x |
checkmate::assert_string(label_hlt, null.ok = TRUE) |
| 40 | 4x |
checkmate::assert_string(label_llt, null.ok = TRUE) |
| 41 | 4x |
checkmate::assert_string(grade) |
| 42 | 4x |
checkmate::assert_string(label_grade, null.ok = TRUE) |
| 43 | 4x |
checkmate::assert_flag(add_total) |
| 44 | 4x |
checkmate::assert_string(total_label) |
| 45 | 4x |
checkmate::assert_string(na_level) |
| 46 | 4x |
checkmate::assert_flag(drop_arm_levels) |
| 47 | 4x |
checkmate::assert_scalar(prune_freq) |
| 48 | 4x |
checkmate::assert_scalar(prune_diff) |
| 49 | ||
| 50 | 4x |
y <- list() |
| 51 | ||
| 52 | 4x |
data_list <- list() |
| 53 | ||
| 54 | 4x |
data_list <- add_expr( |
| 55 | 4x |
data_list, |
| 56 | 4x |
substitute( |
| 57 | 4x |
expr = anl <- dataname, |
| 58 | 4x |
env = list( |
| 59 | 4x |
dataname = as.name(dataname) |
| 60 |
) |
|
| 61 |
) |
|
| 62 |
) |
|
| 63 | ||
| 64 | 4x |
data_list <- add_expr( |
| 65 | 4x |
data_list, |
| 66 | 4x |
prepare_arm_levels( |
| 67 | 4x |
dataname = "anl", |
| 68 | 4x |
parentname = parentname, |
| 69 | 4x |
arm_var = arm_var, |
| 70 | 4x |
drop_arm_levels = drop_arm_levels |
| 71 |
) |
|
| 72 |
) |
|
| 73 | ||
| 74 | 4x |
data_list <- add_expr( |
| 75 | 4x |
data_list, |
| 76 | 4x |
substitute( |
| 77 | 4x |
expr = dataname <- df_explicit_na(dataname, na_level = na_str), |
| 78 | 4x |
env = list(dataname = as.name(dataname), na_str = na_level) |
| 79 |
) |
|
| 80 |
) |
|
| 81 | 4x |
data_list <- add_expr( |
| 82 | 4x |
data_list, |
| 83 | 4x |
substitute( |
| 84 | 4x |
expr = dataname <- df_explicit_na(dataname, na_level = na_str), |
| 85 | 4x |
env = list(dataname = as.name("anl"), na_str = na_level)
|
| 86 |
) |
|
| 87 |
) |
|
| 88 | 4x |
data_list <- add_expr( |
| 89 | 4x |
data_list, |
| 90 | 4x |
substitute( |
| 91 | 4x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 92 | 4x |
env = list(parentname = as.name(parentname), na_str = na_level) |
| 93 |
) |
|
| 94 |
) |
|
| 95 | ||
| 96 | 4x |
data_list <- add_expr( |
| 97 | 4x |
data_list, |
| 98 | 4x |
substitute( |
| 99 | 4x |
expr = grade_groups <- list("- Any Intensity -" = levels(dataname$grade)),
|
| 100 | 4x |
env = list( |
| 101 | 4x |
dataname = as.name(dataname), |
| 102 | 4x |
grade = grade |
| 103 |
) |
|
| 104 |
) |
|
| 105 |
) |
|
| 106 | ||
| 107 | 4x |
y$data <- bracket_expr(data_list) |
| 108 | ||
| 109 | 4x |
y$layout_prep <- quote(split_fun <- trim_levels_in_group) |
| 110 | ||
| 111 | 4x |
layout_list <- list() |
| 112 | ||
| 113 | 4x |
basic_title <- if (is.null(hlt) && !is.null(llt)) {
|
| 114 | ! |
paste0("Adverse Event summary by ", label_grade, ": ", label_llt)
|
| 115 | 4x |
} else if (!is.null(hlt) && is.null(llt)) {
|
| 116 | 1x |
paste0("Adverse Event summary by ", label_grade, ": ", label_hlt)
|
| 117 | 4x |
} else if (!is.null(hlt) && !is.null(llt)) {
|
| 118 | 3x |
paste0("Adverse Event summary by ", label_grade, ": ", label_hlt, " and ", label_llt)
|
| 119 |
} else {
|
|
| 120 | ! |
paste0("Adverse Event summary by ", label_grade)
|
| 121 |
} |
|
| 122 | ||
| 123 | 4x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 124 | 4x |
teal.widgets::resolve_basic_table_args( |
| 125 | 4x |
user_table = basic_table_args, |
| 126 | 4x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE, title = basic_title) |
| 127 |
) |
|
| 128 |
) |
|
| 129 | ||
| 130 | 4x |
layout_list <- add_expr( |
| 131 | 4x |
layout_list, |
| 132 | 4x |
parsed_basic_table_args |
| 133 |
) |
|
| 134 | ||
| 135 | 4x |
layout_list <- add_expr( |
| 136 | 4x |
layout_list, |
| 137 | 4x |
substitute( |
| 138 | 4x |
expr = rtables::split_cols_by(arm_var), |
| 139 | 4x |
env = list(arm_var = arm_var) |
| 140 |
) |
|
| 141 |
) |
|
| 142 | ||
| 143 | 4x |
if (add_total) {
|
| 144 | 3x |
layout_list <- add_expr( |
| 145 | 3x |
layout_list, |
| 146 | 3x |
substitute( |
| 147 | 3x |
expr = rtables::add_overall_col(label = total_label), |
| 148 | 3x |
env = list(total_label = total_label) |
| 149 |
) |
|
| 150 |
) |
|
| 151 |
} |
|
| 152 | ||
| 153 | 4x |
one_term <- is.null(hlt) || is.null(llt) |
| 154 | ||
| 155 | 4x |
if (one_term) {
|
| 156 | 1x |
term_var <- ifelse(is.null(hlt), llt, hlt) |
| 157 | 1x |
layout_list <- add_expr( |
| 158 | 1x |
layout_list, |
| 159 | 1x |
substitute( |
| 160 | 1x |
expr = summarize_occurrences_by_grade( |
| 161 | 1x |
var = grade, |
| 162 | 1x |
grade_groups = grade_groups, |
| 163 | 1x |
na_str = na_str |
| 164 |
) %>% |
|
| 165 | 1x |
rtables::split_rows_by( |
| 166 | 1x |
term_var, |
| 167 | 1x |
child_labels = "visible", |
| 168 | 1x |
nested = TRUE, |
| 169 | 1x |
indent_mod = -1L, |
| 170 | 1x |
split_fun = split_fun(grade), |
| 171 | 1x |
label_pos = "topleft", |
| 172 | 1x |
split_label = teal.data::col_labels(dataname[term_var]) |
| 173 |
) %>% |
|
| 174 | 1x |
summarize_num_patients( |
| 175 | 1x |
var = id, |
| 176 | 1x |
.stats = "unique", |
| 177 | 1x |
.labels = c("- Any Intensity -"),
|
| 178 | 1x |
na_str = na_str |
| 179 |
) %>% |
|
| 180 | 1x |
count_occurrences_by_grade(var = grade, .indent_mods = -1L, na_str = na_str) %>% |
| 181 | 1x |
append_varlabels(dataname, grade, indent = 1L), |
| 182 | 1x |
env = list( |
| 183 | 1x |
id = id, |
| 184 | 1x |
arm_var = arm_var, |
| 185 | 1x |
term_var = term_var, |
| 186 | 1x |
grade = grade, |
| 187 | 1x |
dataname = as.name(dataname), |
| 188 | 1x |
na_str = na_level |
| 189 |
) |
|
| 190 |
) |
|
| 191 |
) |
|
| 192 |
} else {
|
|
| 193 | 3x |
layout_list <- add_expr( |
| 194 | 3x |
layout_list, |
| 195 | 3x |
substitute( |
| 196 | 3x |
expr = summarize_occurrences_by_grade( |
| 197 | 3x |
var = grade, |
| 198 | 3x |
grade_groups = grade_groups, |
| 199 | 3x |
na_str = na_str |
| 200 |
) %>% |
|
| 201 | 3x |
rtables::split_rows_by( |
| 202 | 3x |
hlt, |
| 203 | 3x |
child_labels = "visible", |
| 204 | 3x |
nested = TRUE, |
| 205 | 3x |
indent_mod = -1L, |
| 206 | 3x |
split_fun = split_fun(grade), |
| 207 | 3x |
label_pos = "topleft", |
| 208 | 3x |
split_label = teal.data::col_labels(dataname[hlt]) |
| 209 |
) %>% |
|
| 210 | 3x |
summarize_occurrences_by_grade( |
| 211 | 3x |
var = grade, |
| 212 | 3x |
grade_groups = grade_groups, |
| 213 | 3x |
na_str = na_str |
| 214 |
) %>% |
|
| 215 | 3x |
rtables::split_rows_by( |
| 216 | 3x |
llt, |
| 217 | 3x |
child_labels = "visible", |
| 218 | 3x |
nested = TRUE, |
| 219 | 3x |
indent_mod = -1L, |
| 220 | 3x |
split_fun = split_fun(grade), |
| 221 | 3x |
label_pos = "topleft", |
| 222 | 3x |
split_label = teal.data::col_labels(dataname[llt]) |
| 223 |
) %>% |
|
| 224 | 3x |
summarize_num_patients( |
| 225 | 3x |
var = id, |
| 226 | 3x |
.stats = "unique", |
| 227 | 3x |
.labels = c("- Any Intensity -"),
|
| 228 | 3x |
na_str = na_str |
| 229 |
) %>% |
|
| 230 | 3x |
count_occurrences_by_grade(var = grade, .indent_mods = -1L, na_str = na_str) %>% |
| 231 | 3x |
append_varlabels(dataname, grade, indent = 2L), |
| 232 | 3x |
env = list( |
| 233 | 3x |
id = id, |
| 234 | 3x |
arm_var = arm_var, |
| 235 | 3x |
hlt = hlt, |
| 236 | 3x |
llt = llt, |
| 237 | 3x |
grade = grade, |
| 238 | 3x |
dataname = as.name(dataname), |
| 239 | 3x |
na_str = na_level |
| 240 |
) |
|
| 241 |
) |
|
| 242 |
) |
|
| 243 |
} |
|
| 244 | ||
| 245 | 4x |
y$layout <- substitute( |
| 246 | 4x |
expr = lyt <- layout_pipe, |
| 247 | 4x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 248 |
) |
|
| 249 | ||
| 250 |
# Full table. |
|
| 251 | 4x |
y$table <- substitute( |
| 252 | 4x |
expr = result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent), |
| 253 | 4x |
env = list(parent = as.name(parentname)) |
| 254 |
) |
|
| 255 | ||
| 256 |
# Start pruning table. |
|
| 257 | 4x |
prune_list <- list() |
| 258 | 4x |
prune_list <- add_expr( |
| 259 | 4x |
prune_list, |
| 260 | 4x |
quote( |
| 261 | 4x |
pruned_result <- result |
| 262 |
) |
|
| 263 |
) |
|
| 264 | ||
| 265 | 4x |
if (prune_freq > 0 || prune_diff > 0) {
|
| 266 |
# Do not use "All Patients" column for pruning conditions. |
|
| 267 | 1x |
prune_list <- add_expr( |
| 268 | 1x |
prune_list, |
| 269 | 1x |
substitute( |
| 270 | 1x |
expr = col_indices <- 1:(ncol(result) - add_total), |
| 271 | 1x |
env = list(add_total = add_total) |
| 272 |
) |
|
| 273 |
) |
|
| 274 | ||
| 275 | 1x |
if (prune_freq > 0 && prune_diff == 0) {
|
| 276 | ! |
prune_list <- add_expr( |
| 277 | ! |
prune_list, |
| 278 | ! |
substitute( |
| 279 | ! |
expr = row_condition <- has_fraction_in_any_col(atleast = prune_freq, col_indices = col_indices), |
| 280 | ! |
env = list(prune_freq = prune_freq) |
| 281 |
) |
|
| 282 |
) |
|
| 283 | 1x |
} else if (prune_freq == 0 && prune_diff > 0) {
|
| 284 | ! |
prune_list <- add_expr( |
| 285 | ! |
prune_list, |
| 286 | ! |
substitute( |
| 287 | ! |
expr = row_condition <- has_fractions_difference(atleast = prune_diff, col_indices = col_indices), |
| 288 | ! |
env = list(prune_diff = prune_diff) |
| 289 |
) |
|
| 290 |
) |
|
| 291 | 1x |
} else if (prune_freq > 0 && prune_diff > 0) {
|
| 292 | 1x |
prune_list <- add_expr( |
| 293 | 1x |
prune_list, |
| 294 | 1x |
substitute( |
| 295 | 1x |
expr = row_condition <- has_fraction_in_any_col(atleast = prune_freq, col_indices = col_indices) & |
| 296 | 1x |
has_fractions_difference(atleast = prune_diff, col_indices = col_indices), |
| 297 | 1x |
env = list(prune_freq = prune_freq, prune_diff = prune_diff) |
| 298 |
) |
|
| 299 |
) |
|
| 300 |
} |
|
| 301 | ||
| 302 |
# Apply pruning conditions. |
|
| 303 | 1x |
prune_list <- add_expr( |
| 304 | 1x |
prune_list, |
| 305 | 1x |
substitute( |
| 306 | 1x |
expr = pruned_result <- pruned_result %>% rtables::prune_table(keep_content_rows(row_condition)) |
| 307 |
) |
|
| 308 |
) |
|
| 309 |
} |
|
| 310 | ||
| 311 | 4x |
y$prune <- bracket_expr(prune_list) |
| 312 | ||
| 313 |
# Start sort the pruned table. |
|
| 314 | 4x |
sort_list <- list() |
| 315 | 4x |
scorefun <- if (add_total) {
|
| 316 | 3x |
substitute( |
| 317 | 3x |
expr = cont_n_onecol(length(levels(parent$arm_var)) + 1), |
| 318 | 3x |
env = list( |
| 319 | 3x |
parent = as.name(parentname), |
| 320 | 3x |
arm_var = as.name(arm_var) |
| 321 |
) |
|
| 322 |
) |
|
| 323 |
} else {
|
|
| 324 | 1x |
quote(cont_n_allcols) |
| 325 |
} |
|
| 326 | 4x |
if (one_term) {
|
| 327 | 1x |
term_var <- ifelse(is.null(hlt), llt, hlt) |
| 328 | ||
| 329 | 1x |
sort_list <- add_expr( |
| 330 | 1x |
sort_list, |
| 331 | 1x |
substitute( |
| 332 | 1x |
expr = {
|
| 333 | ! |
pruned_and_sorted_result <- pruned_result %>% |
| 334 | ! |
sort_at_path(path = term_var, scorefun = scorefun, decreasing = TRUE) |
| 335 | ! |
pruned_and_sorted_result |
| 336 |
}, |
|
| 337 | 1x |
env = list( |
| 338 | 1x |
term_var = term_var, |
| 339 | 1x |
scorefun = scorefun |
| 340 |
) |
|
| 341 |
) |
|
| 342 |
) |
|
| 343 |
} else {
|
|
| 344 | 3x |
sort_list <- add_expr( |
| 345 | 3x |
sort_list, |
| 346 | 3x |
substitute( |
| 347 | 3x |
expr = {
|
| 348 | ! |
pruned_and_sorted_result <- pruned_result %>% |
| 349 | ! |
sort_at_path(path = hlt, scorefun = scorefun, decreasing = TRUE) %>% |
| 350 | ! |
sort_at_path(path = c(hlt, "*", llt), scorefun = scorefun, decreasing = TRUE) |
| 351 |
}, |
|
| 352 | 3x |
env = list( |
| 353 | 3x |
llt = llt, |
| 354 | 3x |
hlt = hlt, |
| 355 | 3x |
scorefun = scorefun |
| 356 |
) |
|
| 357 |
) |
|
| 358 |
) |
|
| 359 | ||
| 360 | 3x |
sort_list <- add_expr( |
| 361 | 3x |
sort_list, |
| 362 | 3x |
quote(pruned_and_sorted_result) |
| 363 |
) |
|
| 364 |
} |
|
| 365 | 4x |
y$sort <- bracket_expr(sort_list) |
| 366 | ||
| 367 | 4x |
y |
| 368 |
} |
|
| 369 | ||
| 370 |
#' Template: Adverse Events Grouped by Grade with Threshold |
|
| 371 |
#' |
|
| 372 |
#' Creates a valid expression to generate a table to summarize adverse events grouped by grade. |
|
| 373 |
#' |
|
| 374 |
#' @inheritParams template_arguments |
|
| 375 |
#' @param id (`character`)\cr name of variable to uniquely identify patients in datasets. |
|
| 376 |
#' @param grade (`character`)\cr name of grade variable to base `grading_groups` on. |
|
| 377 |
#' @param label_grade (`character`)\cr label of the `grade` variable from `dataname`. |
|
| 378 |
#' @param grading_groups (`list`)\cr named list of grading groups. |
|
| 379 |
#' |
|
| 380 |
#' @inherit template_arguments return |
|
| 381 |
#' |
|
| 382 |
#' @seealso [tm_t_events_by_grade()] |
|
| 383 |
#' @keywords internal |
|
| 384 |
#' |
|
| 385 |
template_events_col_by_grade <- function(dataname, |
|
| 386 |
parentname, |
|
| 387 |
arm_var, |
|
| 388 |
grading_groups = list( |
|
| 389 |
"Any Grade (%)" = c("1", "2", "3", "4", "5"),
|
|
| 390 |
"Grade 1-2 (%)" = c("1", "2"),
|
|
| 391 |
"Grade 3-4 (%)" = c("3", "4"),
|
|
| 392 |
"Grade 5 (%)" = "5" |
|
| 393 |
), |
|
| 394 |
add_total = TRUE, |
|
| 395 |
total_label = default_total_label(), |
|
| 396 |
id = "USUBJID", |
|
| 397 |
hlt, |
|
| 398 |
llt, |
|
| 399 |
label_hlt = NULL, |
|
| 400 |
label_llt = NULL, |
|
| 401 |
grade = "AETOXGR", |
|
| 402 |
label_grade = NULL, |
|
| 403 |
prune_freq = 0.1, |
|
| 404 |
prune_diff = 0, |
|
| 405 |
na_level = default_na_str(), |
|
| 406 |
drop_arm_levels = TRUE, |
|
| 407 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 408 | 4x |
checkmate::assert_string(dataname) |
| 409 | 4x |
checkmate::assert_string(parentname) |
| 410 | 4x |
checkmate::assert_string(arm_var) |
| 411 | 4x |
checkmate::assert_list(grading_groups) |
| 412 | 4x |
checkmate::assert_flag(add_total) |
| 413 | 4x |
checkmate::assert_string(total_label) |
| 414 | 4x |
checkmate::assert_string(id) |
| 415 | 4x |
checkmate::assert_string(hlt, null.ok = TRUE) |
| 416 | 4x |
checkmate::assert_string(llt) |
| 417 | 4x |
checkmate::assert_string(grade) |
| 418 | 4x |
checkmate::assert_string(label_hlt, null.ok = TRUE) |
| 419 | 4x |
checkmate::assert_string(label_llt, null.ok = TRUE) |
| 420 | 4x |
checkmate::assert_string(label_grade, null.ok = TRUE) |
| 421 | 4x |
checkmate::assert_string(na_level) |
| 422 | 4x |
checkmate::assert_flag(drop_arm_levels) |
| 423 | 4x |
checkmate::assert_scalar(prune_freq) |
| 424 | 4x |
checkmate::assert_scalar(prune_diff) |
| 425 | ||
| 426 | 4x |
y <- list() |
| 427 | ||
| 428 |
# Start data steps. |
|
| 429 | 4x |
data_list <- list() |
| 430 | ||
| 431 | 4x |
data_list <- add_expr( |
| 432 | 4x |
data_list, |
| 433 | 4x |
substitute( |
| 434 | 4x |
expr = anl <- df, |
| 435 | 4x |
env = list(df = as.name(dataname)) |
| 436 |
) |
|
| 437 |
) |
|
| 438 | ||
| 439 | 4x |
data_list <- add_expr( |
| 440 | 4x |
data_list, |
| 441 | 4x |
prepare_arm_levels( |
| 442 | 4x |
dataname = "anl", |
| 443 | 4x |
parentname = parentname, |
| 444 | 4x |
arm_var = arm_var, |
| 445 | 4x |
drop_arm_levels = drop_arm_levels |
| 446 |
) |
|
| 447 |
) |
|
| 448 | ||
| 449 |
## add_total for patients grouping across all arms |
|
| 450 | 4x |
if (add_total) {
|
| 451 | 2x |
data_list <- add_expr( |
| 452 | 2x |
data_list, |
| 453 | 2x |
substitute( |
| 454 | 2x |
col_counts <- rep(c(table(parentname[[arm_var]]), nrow(parentname)), each = length(grading_groups)), |
| 455 | 2x |
env = list(parentname = as.name(parentname), grading_groups = grading_groups, arm_var = arm_var) |
| 456 |
) |
|
| 457 |
) |
|
| 458 |
} else {
|
|
| 459 | 2x |
data_list <- add_expr( |
| 460 | 2x |
data_list, |
| 461 | 2x |
substitute( |
| 462 | 2x |
col_counts <- rep(table(parentname[[arm_var]]), each = length(grading_groups)), |
| 463 | 2x |
env = list(parentname = as.name(parentname), grading_groups = grading_groups, arm_var = arm_var) |
| 464 |
) |
|
| 465 |
) |
|
| 466 |
} |
|
| 467 | ||
| 468 | 4x |
data_pipe <- list() |
| 469 | 4x |
if (!is.null(hlt)) {
|
| 470 | 1x |
data_pipe <- add_expr( |
| 471 | 1x |
data_pipe, |
| 472 | 1x |
substitute( |
| 473 | 1x |
expr = anl <- anl %>% dplyr::group_by(id, arm_var, hlt, llt), |
| 474 | 1x |
env = list(id = as.name(id), arm_var = as.name(arm_var), hlt = as.name(hlt), llt = as.name(llt)) |
| 475 |
) |
|
| 476 |
) |
|
| 477 |
} else {
|
|
| 478 | 3x |
data_pipe <- add_expr( |
| 479 | 3x |
data_pipe, |
| 480 | 3x |
substitute( |
| 481 | 3x |
expr = anl <- anl %>% dplyr::group_by(id, arm_var, llt), |
| 482 | 3x |
env = list(id = as.name(id), arm_var = as.name(arm_var), llt = as.name(llt)) |
| 483 |
) |
|
| 484 |
) |
|
| 485 |
} |
|
| 486 | ||
| 487 | 4x |
data_pipe <- add_expr( |
| 488 | 4x |
data_pipe, |
| 489 | 4x |
substitute( |
| 490 | 4x |
expr = dplyr::summarize(MAXAETOXGR = factor(max(as.numeric(grade)))), |
| 491 | 4x |
env = list(grade = as.name(grade)) |
| 492 |
) |
|
| 493 |
) |
|
| 494 | 4x |
data_pipe <- add_expr( |
| 495 | 4x |
data_pipe, |
| 496 | 4x |
quote(dplyr::ungroup()) |
| 497 |
) |
|
| 498 | 4x |
data_pipe <- add_expr( |
| 499 | 4x |
data_pipe, |
| 500 | 4x |
substitute( |
| 501 | 4x |
expr = df_explicit_na(na_level = na_str), |
| 502 | 4x |
env = list(na_str = na_level) |
| 503 |
) |
|
| 504 |
) |
|
| 505 | 4x |
data_pipe <- pipe_expr(data_pipe) |
| 506 | 4x |
data_list <- add_expr( |
| 507 | 4x |
data_list, |
| 508 | 4x |
data_pipe |
| 509 |
) |
|
| 510 | 4x |
y$data <- bracket_expr(data_list) |
| 511 | ||
| 512 | 4x |
layout_list <- list() |
| 513 | 4x |
basic_title <- if (is.null(hlt) && !is.null(llt)) {
|
| 514 | 3x |
paste0("Adverse Event summary by ", label_grade, ": ", label_llt)
|
| 515 | 4x |
} else if (!is.null(hlt) && is.null(llt)) {
|
| 516 | ! |
paste0("Adverse Event summary by ", label_grade, ": ", label_hlt)
|
| 517 | 4x |
} else if (!is.null(hlt) && !is.null(llt)) {
|
| 518 | 1x |
paste0("Adverse Event summary by ", label_grade, ": ", label_hlt, " and ", label_llt)
|
| 519 |
} else {
|
|
| 520 | ! |
paste0("Adverse Event summary by ", label_grade)
|
| 521 |
} |
|
| 522 | ||
| 523 | ||
| 524 | 4x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 525 | 4x |
teal.widgets::resolve_basic_table_args( |
| 526 | 4x |
user_table = basic_table_args, |
| 527 | 4x |
module_table = teal.widgets::basic_table_args(title = basic_title) |
| 528 |
) |
|
| 529 |
) |
|
| 530 | ||
| 531 |
# Start layout steps. |
|
| 532 | 4x |
layout_list <- list() |
| 533 | 4x |
layout_list <- add_expr( |
| 534 | 4x |
layout_list, |
| 535 | 4x |
parsed_basic_table_args |
| 536 |
) |
|
| 537 | ||
| 538 | 4x |
if (add_total) {
|
| 539 | 2x |
layout_list <- add_expr( |
| 540 | 2x |
layout_list, |
| 541 | 2x |
substitute( |
| 542 | 2x |
expr = rtables::split_cols_by(var = arm_var, split_fun = add_overall_level(total_label, first = FALSE)), |
| 543 | 2x |
env = list( |
| 544 | 2x |
arm_var = arm_var, |
| 545 | 2x |
total_label = total_label |
| 546 |
) |
|
| 547 |
) |
|
| 548 |
) |
|
| 549 |
} else {
|
|
| 550 | 2x |
layout_list <- add_expr( |
| 551 | 2x |
layout_list, |
| 552 | 2x |
substitute( |
| 553 | 2x |
expr = rtables::split_cols_by(var = arm_var), |
| 554 | 2x |
env = list(arm_var = arm_var) |
| 555 |
) |
|
| 556 |
) |
|
| 557 |
} |
|
| 558 | ||
| 559 | 4x |
layout_list <- add_expr( |
| 560 | 4x |
layout_list, |
| 561 | 4x |
substitute( |
| 562 | 4x |
expr = split_cols_by_groups("MAXAETOXGR", groups = grading_groups),
|
| 563 | 4x |
env = list(grading_groups = grading_groups) |
| 564 |
) |
|
| 565 |
) |
|
| 566 | ||
| 567 | 4x |
if (!is.null(hlt)) {
|
| 568 | 1x |
layout_list <- add_expr( |
| 569 | 1x |
layout_list, |
| 570 | 1x |
substitute( |
| 571 | 1x |
expr = rtables::split_rows_by( |
| 572 | 1x |
hlt, |
| 573 | 1x |
child_labels = "visible", |
| 574 | 1x |
nested = FALSE, |
| 575 | 1x |
split_fun = trim_levels_in_group(llt) |
| 576 |
), |
|
| 577 | 1x |
env = list(hlt = hlt, llt = llt) |
| 578 |
) |
|
| 579 |
) |
|
| 580 | ||
| 581 | 1x |
layout_list <- add_expr( |
| 582 | 1x |
layout_list, |
| 583 | 1x |
substitute( |
| 584 | 1x |
expr = append_varlabels(df = anl, vars = hlt), |
| 585 | 1x |
env = list(hlt = hlt) |
| 586 |
) |
|
| 587 |
) |
|
| 588 | ||
| 589 | 1x |
unique_label <- paste0("Total number of patients with at least one adverse event")
|
| 590 | 1x |
layout_list <- add_expr( |
| 591 | 1x |
layout_list, |
| 592 | 1x |
substitute( |
| 593 | 1x |
summarize_num_patients( |
| 594 | 1x |
var = id, |
| 595 | 1x |
.stats = "unique", |
| 596 | 1x |
.labels = unique_label, |
| 597 |
), |
|
| 598 | 1x |
env = list(id = id, unique_label = unique_label) |
| 599 |
) |
|
| 600 |
) |
|
| 601 |
} |
|
| 602 | ||
| 603 | 4x |
layout_list <- add_expr( |
| 604 | 4x |
layout_list, |
| 605 | 4x |
substitute( |
| 606 | 4x |
analyze_vars( |
| 607 | 4x |
llt, |
| 608 | 4x |
na.rm = FALSE, |
| 609 | 4x |
denom = "N_col", |
| 610 | 4x |
.stats = "count_fraction", |
| 611 | 4x |
.formats = c(count_fraction = format_fraction_threshold(0.01)) |
| 612 |
), |
|
| 613 | 4x |
env = list(llt = llt) |
| 614 |
) |
|
| 615 |
) |
|
| 616 | ||
| 617 | 4x |
if (is.null(hlt)) {
|
| 618 | 3x |
layout_list <- add_expr( |
| 619 | 3x |
layout_list, |
| 620 | 3x |
substitute( |
| 621 | 3x |
expr = append_varlabels(df = anl, vars = llt), |
| 622 | 3x |
env = list(llt = llt) |
| 623 |
) |
|
| 624 |
) |
|
| 625 |
} else {
|
|
| 626 | 1x |
layout_list <- add_expr( |
| 627 | 1x |
layout_list, |
| 628 | 1x |
substitute( |
| 629 | 1x |
expr = append_varlabels(df = anl, vars = llt, indent = 1L), |
| 630 | 1x |
env = list(llt = llt) |
| 631 |
) |
|
| 632 |
) |
|
| 633 |
} |
|
| 634 | ||
| 635 | 4x |
y$layout <- substitute( |
| 636 | 4x |
expr = lyt <- layout_pipe, |
| 637 | 4x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 638 |
) |
|
| 639 | ||
| 640 |
# Full table. |
|
| 641 | 4x |
y$table <- quote(result <- rtables::build_table(lyt = lyt, df = anl, col_counts = col_counts)) |
| 642 | ||
| 643 |
# Start sorting table. |
|
| 644 | 4x |
sort_list <- list() |
| 645 | ||
| 646 | 4x |
sort_list <- add_expr( |
| 647 | 4x |
sort_list, |
| 648 | 4x |
substitute( |
| 649 | 4x |
expr = lengths <- lapply(grading_groups, length), |
| 650 | 4x |
env = list(grading_groups = grading_groups) |
| 651 |
) |
|
| 652 |
) |
|
| 653 | 4x |
sort_list <- add_expr( |
| 654 | 4x |
sort_list, |
| 655 | 4x |
quote(start_index <- unname(which.max(lengths))) |
| 656 |
) |
|
| 657 | 4x |
sort_list <- add_expr( |
| 658 | 4x |
sort_list, |
| 659 | 4x |
substitute( |
| 660 | 4x |
expr = col_indices <- seq(start_index, ncol(result), by = length(grading_groups)), |
| 661 | 4x |
env = list(grading_groups = grading_groups) |
| 662 |
) |
|
| 663 |
) |
|
| 664 | ||
| 665 | 4x |
if (!is.null(hlt)) {
|
| 666 | 1x |
sort_list <- add_expr( |
| 667 | 1x |
sort_list, |
| 668 | 1x |
quote(scorefun_soc <- score_occurrences_cont_cols(col_indices = col_indices)) |
| 669 |
) |
|
| 670 |
} |
|
| 671 | ||
| 672 | 4x |
sort_list <- add_expr( |
| 673 | 4x |
sort_list, |
| 674 | 4x |
quote(scorefun_term <- score_occurrences_cols(col_indices = col_indices)) |
| 675 |
) |
|
| 676 | ||
| 677 | 4x |
if (is.null(hlt)) {
|
| 678 | 3x |
sort_list <- add_expr( |
| 679 | 3x |
sort_list, |
| 680 | 3x |
substitute( |
| 681 | 3x |
expr = {
|
| 682 | ! |
sorted_result <- result %>% |
| 683 | ! |
sort_at_path(path = c(llt), scorefun = scorefun_term, decreasing = TRUE) |
| 684 |
}, |
|
| 685 | 3x |
env = list(llt = llt) |
| 686 |
) |
|
| 687 |
) |
|
| 688 |
} else {
|
|
| 689 | 1x |
sort_list <- add_expr( |
| 690 | 1x |
sort_list, |
| 691 | 1x |
substitute( |
| 692 | 1x |
expr = {
|
| 693 | ! |
sorted_result <- result %>% |
| 694 | ! |
sort_at_path(path = c(hlt), scorefun = scorefun_soc, decreasing = TRUE) %>% |
| 695 | ! |
sort_at_path(path = c(hlt, "*", llt), scorefun = scorefun_term, decreasing = TRUE) |
| 696 |
}, |
|
| 697 | 1x |
env = list( |
| 698 | 1x |
hlt = hlt, |
| 699 | 1x |
llt = llt |
| 700 |
) |
|
| 701 |
) |
|
| 702 |
) |
|
| 703 |
} |
|
| 704 | ||
| 705 | 4x |
y$sort <- bracket_expr(sort_list) |
| 706 | ||
| 707 |
# Start pruning table. |
|
| 708 | 4x |
prune_list <- list() |
| 709 | 4x |
prune_list <- add_expr( |
| 710 | 4x |
prune_list, |
| 711 | 4x |
quote( |
| 712 | 4x |
criteria_fun <- function(tr) {
|
| 713 | ! |
inherits(tr, "ContentRow") |
| 714 |
} |
|
| 715 |
) |
|
| 716 |
) |
|
| 717 | ||
| 718 | 4x |
if (prune_freq > 0) {
|
| 719 | 4x |
prune_list <- add_expr( |
| 720 | 4x |
prune_list, |
| 721 | 4x |
substitute( |
| 722 | 4x |
expr = at_least_percent_any <- has_fraction_in_any_col(atleast = prune_freq, col_indices = col_indices), |
| 723 | 4x |
env = list(prune_freq = prune_freq) |
| 724 |
) |
|
| 725 |
) |
|
| 726 |
} |
|
| 727 | ||
| 728 | 4x |
if (prune_diff > 0) {
|
| 729 | ! |
prune_list <- add_expr( |
| 730 | ! |
prune_list, |
| 731 | ! |
substitute( |
| 732 | ! |
expr = at_least_percent_diff <- has_fractions_difference(atleast = prune_diff, col_indices = col_indices), |
| 733 | ! |
env = list(prune_diff = prune_diff) |
| 734 |
) |
|
| 735 |
) |
|
| 736 |
} |
|
| 737 | ||
| 738 | 4x |
prune_pipe <- list() |
| 739 | 4x |
prune_pipe <- add_expr( |
| 740 | 4x |
prune_pipe, |
| 741 | 4x |
quote( |
| 742 | 4x |
pruned_and_sorted_result <- sorted_result %>% rtables::trim_rows(criteria = criteria_fun) |
| 743 |
) |
|
| 744 |
) |
|
| 745 | ||
| 746 | 4x |
if (prune_freq > 0 && prune_diff > 0) {
|
| 747 | ! |
prune_pipe <- add_expr( |
| 748 | ! |
prune_pipe, |
| 749 | ! |
quote(rtables::prune_table(keep_rows(at_least_percent_any & at_least_percent_diff))) |
| 750 |
) |
|
| 751 | 4x |
} else if (prune_freq > 0 && prune_diff == 0) {
|
| 752 | 4x |
prune_pipe <- add_expr( |
| 753 | 4x |
prune_pipe, |
| 754 | 4x |
quote(rtables::prune_table(keep_rows(at_least_percent_any))) |
| 755 |
) |
|
| 756 | ! |
} else if (prune_freq == 0 && prune_diff > 0) {
|
| 757 | ! |
prune_pipe <- add_expr( |
| 758 | ! |
prune_pipe, |
| 759 | ! |
quote(rtables::prune_table(keep_rows(at_least_percent_diff))) |
| 760 |
) |
|
| 761 |
} else {
|
|
| 762 | ! |
prune_pipe <- add_expr( |
| 763 | ! |
prune_pipe, |
| 764 | ! |
quote(rtables::prune_table()) |
| 765 |
) |
|
| 766 |
} |
|
| 767 | 4x |
prune_pipe <- pipe_expr(prune_pipe) |
| 768 | 4x |
prune_list <- add_expr( |
| 769 | 4x |
prune_list, |
| 770 | 4x |
prune_pipe |
| 771 |
) |
|
| 772 | 4x |
prune_list <- add_expr( |
| 773 | 4x |
prune_list, |
| 774 | 4x |
quote(pruned_and_sorted_result) |
| 775 |
) |
|
| 776 | ||
| 777 | 4x |
y$prune <- bracket_expr(prune_list) |
| 778 | ||
| 779 | 4x |
y |
| 780 |
} |
|
| 781 | ||
| 782 |
#' teal Module: Events by Grade |
|
| 783 |
#' |
|
| 784 |
#' This module produces a table to summarize events by grade. |
|
| 785 |
#' |
|
| 786 |
#' @inheritParams module_arguments |
|
| 787 |
#' @inheritParams template_events_by_grade |
|
| 788 |
#' @inheritParams template_events_col_by_grade |
|
| 789 |
#' @param col_by_grade (`logical`)\cr whether to display the grading groups in nested columns. |
|
| 790 |
#' @param grading_groups (`list`)\cr named list of grading groups used when `col_by_grade = TRUE`. |
|
| 791 |
#' |
|
| 792 |
#' @inherit module_arguments return seealso |
|
| 793 |
#' |
|
| 794 |
#' @export |
|
| 795 |
#' @examples |
|
| 796 |
#' data <- teal_data() |
|
| 797 |
#' data <- within(data, {
|
|
| 798 |
#' library(dplyr) |
|
| 799 |
#' |
|
| 800 |
#' ADSL <- tmc_ex_adsl |
|
| 801 |
#' lbls_adae <- col_labels(tmc_ex_adae) |
|
| 802 |
#' ADAE <- tmc_ex_adae %>% |
|
| 803 |
#' mutate_if(is.character, as.factor) #' be certain of having factors |
|
| 804 |
#' col_labels(ADAE) <- lbls_adae |
|
| 805 |
#' }) |
|
| 806 |
#' |
|
| 807 |
#' datanames <- c("ADSL", "ADAE")
|
|
| 808 |
#' datanames(data) <- datanames |
|
| 809 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 810 |
#' |
|
| 811 |
#' app <- init( |
|
| 812 |
#' data = data, |
|
| 813 |
#' modules = modules( |
|
| 814 |
#' tm_t_events_by_grade( |
|
| 815 |
#' label = "Adverse Events by Grade Table", |
|
| 816 |
#' dataname = "ADAE", |
|
| 817 |
#' arm_var = choices_selected(c("ARM", "ARMCD"), "ARM"),
|
|
| 818 |
#' llt = choices_selected( |
|
| 819 |
#' choices = variable_choices(data[["ADAE"]], c("AETERM", "AEDECOD")),
|
|
| 820 |
#' selected = c("AEDECOD")
|
|
| 821 |
#' ), |
|
| 822 |
#' hlt = choices_selected( |
|
| 823 |
#' choices = variable_choices(data[["ADAE"]], c("AEBODSYS", "AESOC")),
|
|
| 824 |
#' selected = "AEBODSYS" |
|
| 825 |
#' ), |
|
| 826 |
#' grade = choices_selected( |
|
| 827 |
#' choices = variable_choices(data[["ADAE"]], c("AETOXGR", "AESEV")),
|
|
| 828 |
#' selected = "AETOXGR" |
|
| 829 |
#' ) |
|
| 830 |
#' ) |
|
| 831 |
#' ) |
|
| 832 |
#' ) |
|
| 833 |
#' if (interactive()) {
|
|
| 834 |
#' shinyApp(app$ui, app$server) |
|
| 835 |
#' } |
|
| 836 |
#' |
|
| 837 |
tm_t_events_by_grade <- function(label, |
|
| 838 |
dataname, |
|
| 839 |
parentname = ifelse( |
|
| 840 |
inherits(arm_var, "data_extract_spec"), |
|
| 841 |
teal.transform::datanames_input(arm_var), |
|
| 842 |
"ADSL" |
|
| 843 |
), |
|
| 844 |
arm_var, |
|
| 845 |
hlt, |
|
| 846 |
llt, |
|
| 847 |
grade, |
|
| 848 |
grading_groups = list( |
|
| 849 |
"Any Grade (%)" = c("1", "2", "3", "4", "5"),
|
|
| 850 |
"Grade 1-2 (%)" = c("1", "2"),
|
|
| 851 |
"Grade 3-4 (%)" = c("3", "4"),
|
|
| 852 |
"Grade 5 (%)" = "5" |
|
| 853 |
), |
|
| 854 |
col_by_grade = FALSE, |
|
| 855 |
prune_freq = 0, |
|
| 856 |
prune_diff = 0, |
|
| 857 |
add_total = TRUE, |
|
| 858 |
total_label = default_total_label(), |
|
| 859 |
na_level = default_na_str(), |
|
| 860 |
drop_arm_levels = TRUE, |
|
| 861 |
pre_output = NULL, |
|
| 862 |
post_output = NULL, |
|
| 863 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 864 | ! |
message("Initializing tm_t_events_by_grade")
|
| 865 | ! |
checkmate::assert_string(label) |
| 866 | ! |
checkmate::assert_string(dataname) |
| 867 | ! |
checkmate::assert_string(parentname) |
| 868 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 869 | ! |
checkmate::assert_class(hlt, "choices_selected") |
| 870 | ! |
checkmate::assert_class(llt, "choices_selected") |
| 871 | ! |
checkmate::assert_flag(add_total) |
| 872 | ! |
checkmate::assert_string(total_label) |
| 873 | ! |
checkmate::assert_string(na_level) |
| 874 | ! |
checkmate::assert_flag(col_by_grade) |
| 875 | ! |
checkmate::assert_scalar(prune_freq) |
| 876 | ! |
checkmate::assert_scalar(prune_diff) |
| 877 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 878 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 879 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 880 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 881 | ||
| 882 | ! |
args <- as.list(environment()) |
| 883 | ||
| 884 | ! |
data_extract_list <- list( |
| 885 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 886 | ! |
hlt = cs_to_des_select(hlt, dataname = dataname), |
| 887 | ! |
llt = cs_to_des_select(llt, dataname = dataname), |
| 888 | ! |
grade = cs_to_des_select(grade, dataname = dataname) |
| 889 |
) |
|
| 890 | ||
| 891 | ! |
module( |
| 892 | ! |
label = label, |
| 893 | ! |
server = srv_t_events_by_grade, |
| 894 | ! |
ui = ui_t_events_by_grade, |
| 895 | ! |
ui_args = c(data_extract_list, args), |
| 896 | ! |
server_args = c( |
| 897 | ! |
data_extract_list, |
| 898 | ! |
list( |
| 899 | ! |
dataname = dataname, |
| 900 | ! |
parentname = parentname, |
| 901 | ! |
label = label, |
| 902 | ! |
total_label = total_label, |
| 903 | ! |
grading_groups = grading_groups, |
| 904 | ! |
na_level = na_level, |
| 905 | ! |
basic_table_args = basic_table_args |
| 906 |
) |
|
| 907 |
), |
|
| 908 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 909 |
) |
|
| 910 |
} |
|
| 911 | ||
| 912 |
#' @keywords internal |
|
| 913 |
ui_t_events_by_grade <- function(id, ...) {
|
|
| 914 | ! |
ns <- NS(id) |
| 915 | ! |
a <- list(...) |
| 916 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset(a$arm_var, a$hlt, a$llt, a$grade) |
| 917 | ||
| 918 | ! |
teal.widgets::standard_layout( |
| 919 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 920 | ! |
encoding = tags$div( |
| 921 |
### Reporter |
|
| 922 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 923 |
### |
|
| 924 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 925 | ! |
teal.transform::datanames_input(a[c("arm_var", "hlt", "llt", "grade")]),
|
| 926 | ! |
teal.transform::data_extract_ui( |
| 927 | ! |
id = ns("arm_var"),
|
| 928 | ! |
label = "Select Treatment Variable", |
| 929 | ! |
data_extract_spec = a$arm_var, |
| 930 | ! |
is_single_dataset = is_single_dataset_value |
| 931 |
), |
|
| 932 | ! |
teal.transform::data_extract_ui( |
| 933 | ! |
id = ns("hlt"),
|
| 934 | ! |
label = "Event High Level Term", |
| 935 | ! |
data_extract_spec = a$hlt, |
| 936 | ! |
is_single_dataset = is_single_dataset_value |
| 937 |
), |
|
| 938 | ! |
teal.transform::data_extract_ui( |
| 939 | ! |
id = ns("llt"),
|
| 940 | ! |
label = "Event Low Level Term", |
| 941 | ! |
data_extract_spec = a$llt, |
| 942 | ! |
is_single_dataset = is_single_dataset_value |
| 943 |
), |
|
| 944 | ! |
teal.transform::data_extract_ui( |
| 945 | ! |
id = ns("grade"),
|
| 946 | ! |
label = "Event Grade", |
| 947 | ! |
data_extract_spec = a$grade, |
| 948 | ! |
is_single_dataset = is_single_dataset_value |
| 949 |
), |
|
| 950 | ! |
checkboxInput( |
| 951 | ! |
ns("add_total"),
|
| 952 | ! |
"Add All Patients column", |
| 953 | ! |
value = a$add_total |
| 954 |
), |
|
| 955 | ! |
checkboxInput( |
| 956 | ! |
ns("col_by_grade"),
|
| 957 | ! |
"Display grade groupings in nested columns", |
| 958 | ! |
value = a$col_by_grade |
| 959 |
), |
|
| 960 | ! |
teal.widgets::panel_group( |
| 961 | ! |
teal.widgets::panel_item( |
| 962 | ! |
"Additional table settings", |
| 963 | ! |
checkboxInput( |
| 964 | ! |
ns("drop_arm_levels"),
|
| 965 | ! |
label = "Drop columns not in filtered analysis dataset", |
| 966 | ! |
value = a$drop_arm_levels |
| 967 |
), |
|
| 968 | ! |
helpText("Pruning Options"),
|
| 969 | ! |
numericInput( |
| 970 | ! |
inputId = ns("prune_freq"),
|
| 971 | ! |
label = "Minimum Incidence Rate(%) in any of the treatment groups", |
| 972 | ! |
value = a$prune_freq, |
| 973 | ! |
min = 0, |
| 974 | ! |
max = 100, |
| 975 | ! |
step = 1, |
| 976 | ! |
width = "100%" |
| 977 |
), |
|
| 978 | ! |
numericInput( |
| 979 | ! |
inputId = ns("prune_diff"),
|
| 980 | ! |
label = "Minimum Difference Rate(%) between any of the treatment groups", |
| 981 | ! |
value = a$prune_diff, |
| 982 | ! |
min = 0, |
| 983 | ! |
max = 100, |
| 984 | ! |
step = 1, |
| 985 | ! |
width = "100%" |
| 986 |
) |
|
| 987 |
) |
|
| 988 |
) |
|
| 989 |
), |
|
| 990 | ! |
forms = tagList( |
| 991 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 992 |
), |
|
| 993 | ! |
pre_output = a$pre_output, |
| 994 | ! |
post_output = a$post_output |
| 995 |
) |
|
| 996 |
} |
|
| 997 | ||
| 998 |
#' @keywords internal |
|
| 999 |
srv_t_events_by_grade <- function(id, |
|
| 1000 |
data, |
|
| 1001 |
reporter, |
|
| 1002 |
filter_panel_api, |
|
| 1003 |
dataname, |
|
| 1004 |
parentname, |
|
| 1005 |
label, |
|
| 1006 |
arm_var, |
|
| 1007 |
hlt, |
|
| 1008 |
llt, |
|
| 1009 |
grade, |
|
| 1010 |
col_by_grade, |
|
| 1011 |
grading_groups, |
|
| 1012 |
drop_arm_levels, |
|
| 1013 |
total_label, |
|
| 1014 |
na_level, |
|
| 1015 |
basic_table_args) {
|
|
| 1016 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 1017 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 1018 | ! |
checkmate::assert_class(data, "reactive") |
| 1019 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 1020 | ||
| 1021 | ! |
moduleServer(id, function(input, output, session) {
|
| 1022 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 1023 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 1024 | ! |
data_extract = list(arm_var = arm_var, hlt = hlt, llt = llt, grade = grade), |
| 1025 | ! |
datasets = data, |
| 1026 | ! |
select_validation_rule = list( |
| 1027 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required"),
|
| 1028 | ! |
grade = shinyvalidate::sv_required("An event grade is required"),
|
| 1029 | ! |
hlt = ~ if (length(selector_list()$llt()$select) + length(.) == 0) {
|
| 1030 | ! |
"Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." |
| 1031 |
}, |
|
| 1032 | ! |
llt = shinyvalidate::compose_rules( |
| 1033 | ! |
~ if (length(selector_list()$hlt()$select) + length(.) == 0) {
|
| 1034 | ! |
"Please select at least one of \"LOW LEVEL TERM\" or \"HIGH LEVEL TERM\" variables." |
| 1035 |
}, |
|
| 1036 | ! |
~ if (col_by_grade() && length(.) == 0) {
|
| 1037 | ! |
"Low Level Term must be present when grade groupings are displayed in nested columns." |
| 1038 |
} |
|
| 1039 |
) |
|
| 1040 |
) |
|
| 1041 |
) |
|
| 1042 | ||
| 1043 | ! |
col_by_grade <- reactive({
|
| 1044 | ! |
input$col_by_grade |
| 1045 |
}) |
|
| 1046 | ||
| 1047 | ! |
iv_r <- reactive({
|
| 1048 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 1049 | ! |
iv$add_rule( |
| 1050 | ! |
"prune_freq", shinyvalidate::sv_required("Please provide an Incidence Rate between 0 and 100 (%).")
|
| 1051 |
) |
|
| 1052 | ! |
iv$add_rule( |
| 1053 | ! |
"prune_freq", |
| 1054 | ! |
shinyvalidate::sv_between(0, 100, message_fmt = "Please provide an Incidence Rate between 0 and 100 (%).") |
| 1055 |
) |
|
| 1056 | ! |
iv$add_rule( |
| 1057 | ! |
"prune_diff", shinyvalidate::sv_required("Please provide a Difference Rate between 0 and 100 (%).")
|
| 1058 |
) |
|
| 1059 | ! |
iv$add_rule( |
| 1060 | ! |
"prune_diff", |
| 1061 | ! |
shinyvalidate::sv_between(0, 100, message_fmt = "Please provide a Difference Rate between 0 and 100 (%).") |
| 1062 |
) |
|
| 1063 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 1064 |
}) |
|
| 1065 | ||
| 1066 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 1067 | ! |
datasets = data, |
| 1068 | ! |
selector_list = selector_list, |
| 1069 | ! |
merge_function = "dplyr::inner_join" |
| 1070 |
) |
|
| 1071 | ||
| 1072 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 1073 | ! |
datasets = data, |
| 1074 | ! |
data_extract = list(arm_var = arm_var), |
| 1075 | ! |
anl_name = "ANL_ADSL" |
| 1076 |
) |
|
| 1077 | ||
| 1078 | ! |
anl_q <- reactive({
|
| 1079 | ! |
data() %>% |
| 1080 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 1081 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 1082 |
}) |
|
| 1083 | ||
| 1084 | ! |
merged <- list( |
| 1085 | ! |
anl_input_r = anl_inputs, |
| 1086 | ! |
adsl_input_r = adsl_inputs, |
| 1087 | ! |
anl_q = anl_q |
| 1088 |
) |
|
| 1089 | ||
| 1090 | ! |
validate_checks <- reactive({
|
| 1091 | ! |
teal::validate_inputs(iv_r()) |
| 1092 | ||
| 1093 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 1094 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 1095 | ! |
adsl_keys <- merged$adsl_input_r()$keys |
| 1096 | ||
| 1097 | ! |
checkmate::assert( |
| 1098 | ! |
.var.name = "adsl_keys", |
| 1099 | ! |
if ("USUBJID" %in% adsl_keys) TRUE else "Must contain \"USUBJID\""
|
| 1100 |
) |
|
| 1101 | ||
| 1102 | ! |
input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) |
| 1103 | ! |
input_level_term <- c( |
| 1104 | ! |
as.vector(merged$anl_input_r()$columns_source$hlt), |
| 1105 | ! |
as.vector(merged$anl_input_r()$columns_source$llt) |
| 1106 |
) |
|
| 1107 | ! |
input_grade <- as.vector(merged$anl_input_r()$columns_source$grade) |
| 1108 | ||
| 1109 | ! |
validate( |
| 1110 | ! |
need(is.factor(adsl_filtered[[input_arm_var]]), "Treatment variable is not a factor.") |
| 1111 |
) |
|
| 1112 | ! |
if (input$col_by_grade) {
|
| 1113 | ! |
validate( |
| 1114 | ! |
need( |
| 1115 | ! |
is.factor(anl_filtered[[input_grade]]) && |
| 1116 | ! |
all(as.character(unique(anl_filtered[[input_grade]])) %in% as.character(c(1:5))), |
| 1117 | ! |
paste( |
| 1118 | ! |
"Data includes records with grade levels outside of 1-5.", |
| 1119 | ! |
"Please use filter panel to exclude from analysis in order to display grade grouping in nested columns." |
| 1120 |
) |
|
| 1121 |
) |
|
| 1122 |
) |
|
| 1123 |
} else {
|
|
| 1124 | ! |
validate( |
| 1125 | ! |
need( |
| 1126 | ! |
is.factor(anl_filtered[[input_grade]]), |
| 1127 | ! |
"Event grade variable must be a factor." |
| 1128 |
) |
|
| 1129 |
) |
|
| 1130 |
} |
|
| 1131 | ||
| 1132 |
# validate inputs |
|
| 1133 | ! |
validate_standard_inputs( |
| 1134 | ! |
adsl = adsl_filtered, |
| 1135 | ! |
adslvars = c(adsl_keys, input_arm_var), |
| 1136 | ! |
anl = anl_filtered, |
| 1137 | ! |
anlvars = c(adsl_keys, input_level_term, input_grade), |
| 1138 | ! |
arm_var = input_arm_var |
| 1139 |
) |
|
| 1140 |
}) |
|
| 1141 | ||
| 1142 |
# The R-code corresponding to the analysis. |
|
| 1143 | ! |
table_q <- reactive({
|
| 1144 | ! |
validate_checks() |
| 1145 | ! |
ANL <- merged$anl_q()[["ANL"]] |
| 1146 | ||
| 1147 | ! |
input_hlt <- as.vector(merged$anl_input_r()$columns_source$hlt) |
| 1148 | ! |
input_llt <- as.vector(merged$anl_input_r()$columns_source$llt) |
| 1149 | ! |
input_grade <- as.vector(merged$anl_input_r()$columns_source$grade) |
| 1150 | ! |
label_hlt <- if (length(input_hlt) != 0) attributes(ANL[[input_hlt]])$label else NULL |
| 1151 | ! |
label_llt <- if (length(input_llt) != 0) attributes(ANL[[input_llt]])$label else NULL |
| 1152 | ! |
label_grade <- if (length(input_grade) != 0) attributes(ANL[[input_grade]])$label else NULL |
| 1153 | ! |
label_grade <- if (is.null(label_grade)) input_grade else NULL |
| 1154 | ||
| 1155 | ! |
my_calls <- if (input$col_by_grade) {
|
| 1156 | ! |
template_events_col_by_grade( |
| 1157 | ! |
dataname = "ANL", |
| 1158 | ! |
parentname = "ANL_ADSL", |
| 1159 | ! |
add_total = input$add_total, |
| 1160 | ! |
total_label = total_label, |
| 1161 | ! |
grading_groups = grading_groups, |
| 1162 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 1163 | ! |
id = "USUBJID", |
| 1164 | ! |
hlt = if (length(input_hlt) != 0) input_hlt else NULL, |
| 1165 | ! |
llt = if (length(input_llt) != 0) input_llt else NULL, |
| 1166 | ! |
label_hlt = label_hlt, |
| 1167 | ! |
label_llt = label_llt, |
| 1168 | ! |
grade = if (length(input_grade) != 0) input_grade else NULL, |
| 1169 | ! |
label_grade = label_grade, |
| 1170 | ! |
prune_freq = input$prune_freq / 100, |
| 1171 | ! |
prune_diff = input$prune_diff / 100, |
| 1172 | ! |
na_level = na_level, |
| 1173 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 1174 | ! |
basic_table_args = basic_table_args |
| 1175 |
) |
|
| 1176 |
} else {
|
|
| 1177 | ! |
template_events_by_grade( |
| 1178 | ! |
dataname = "ANL", |
| 1179 | ! |
parentname = "ANL_ADSL", |
| 1180 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 1181 | ! |
id = "USUBJID", |
| 1182 | ! |
hlt = if (length(input_hlt) != 0) input_hlt else NULL, |
| 1183 | ! |
llt = if (length(input_llt) != 0) input_llt else NULL, |
| 1184 | ! |
label_hlt = label_hlt, |
| 1185 | ! |
label_llt = label_llt, |
| 1186 | ! |
grade = input_grade, |
| 1187 | ! |
label_grade = label_grade, |
| 1188 | ! |
prune_freq = input$prune_freq / 100, |
| 1189 | ! |
prune_diff = input$prune_diff / 100, |
| 1190 | ! |
add_total = input$add_total, |
| 1191 | ! |
total_label = total_label, |
| 1192 | ! |
na_level = na_level, |
| 1193 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 1194 | ! |
basic_table_args = basic_table_args |
| 1195 |
) |
|
| 1196 |
} |
|
| 1197 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 1198 |
}) |
|
| 1199 | ||
| 1200 |
# Outputs to render. |
|
| 1201 | ! |
table_r <- reactive({
|
| 1202 | ! |
table_q()[["pruned_and_sorted_result"]] |
| 1203 |
}) |
|
| 1204 | ||
| 1205 | ! |
teal.widgets::table_with_settings_srv( |
| 1206 | ! |
id = "table", |
| 1207 | ! |
table_r = table_r |
| 1208 |
) |
|
| 1209 | ||
| 1210 |
# Render R code. |
|
| 1211 | ! |
teal.widgets::verbatim_popup_srv( |
| 1212 | ! |
id = "rcode", |
| 1213 | ! |
verbatim_content = reactive(teal.code::get_code(table_q())), |
| 1214 | ! |
title = label |
| 1215 |
) |
|
| 1216 | ||
| 1217 |
### REPORTER |
|
| 1218 | ! |
if (with_reporter) {
|
| 1219 | ! |
card_fun <- function(comment, label) {
|
| 1220 | ! |
card <- teal::report_card_template( |
| 1221 | ! |
title = "Events by Grade Table", |
| 1222 | ! |
label = label, |
| 1223 | ! |
with_filter = with_filter, |
| 1224 | ! |
filter_panel_api = filter_panel_api |
| 1225 |
) |
|
| 1226 | ! |
card$append_text("Table", "header3")
|
| 1227 | ! |
card$append_table(table_r()) |
| 1228 | ! |
if (!comment == "") {
|
| 1229 | ! |
card$append_text("Comment", "header3")
|
| 1230 | ! |
card$append_text(comment) |
| 1231 |
} |
|
| 1232 | ! |
card$append_src(teal.code::get_code(table_q())) |
| 1233 | ! |
card |
| 1234 |
} |
|
| 1235 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1236 |
} |
|
| 1237 |
### |
|
| 1238 |
}) |
|
| 1239 |
} |
| 1 |
#' Template: Patient Profile Laboratory Table |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a patient profile laboratory table using ADaM datasets. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param paramcd (`character`)\cr name of the parameter code variable. |
|
| 7 |
#' @param param (`character`)\cr name of the parameter variable. |
|
| 8 |
#' @param timepoints (`character`)\cr name of time variable. |
|
| 9 |
#' @param anrind (`character`)\cr name of the analysis reference range indicator variable. |
|
| 10 |
#' @param round_value (`numeric`)\cr number of decimal places to round to. |
|
| 11 |
#' |
|
| 12 |
#' @inherit template_arguments return |
|
| 13 |
#' |
|
| 14 |
#' @seealso [tm_t_pp_laboratory()] |
|
| 15 |
#' |
|
| 16 |
#' @keywords internal |
|
| 17 |
template_laboratory <- function(dataname = "ANL", |
|
| 18 |
paramcd = "PARAMCD", |
|
| 19 |
param = "PARAM", |
|
| 20 |
anrind = "ANRIND", |
|
| 21 |
timepoints = "ADY", |
|
| 22 |
aval = lifecycle::deprecated(), |
|
| 23 |
aval_var = "AVAL", |
|
| 24 |
avalu = lifecycle::deprecated(), |
|
| 25 |
avalu_var = "AVALU", |
|
| 26 |
patient_id = NULL, |
|
| 27 |
round_value = 0L) {
|
|
| 28 | ! |
if (lifecycle::is_present(aval)) {
|
| 29 | ! |
aval_var <- aval |
| 30 | ! |
warning( |
| 31 | ! |
"The `aval` argument of `template_laboratory()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 32 | ! |
"Please use the `aval_var` argument instead.", |
| 33 | ! |
call. = FALSE |
| 34 |
) |
|
| 35 |
} |
|
| 36 | ||
| 37 | ! |
if (lifecycle::is_present(avalu)) {
|
| 38 | ! |
avalu_var <- avalu |
| 39 | ! |
warning( |
| 40 | ! |
"The `avalu` argument of `template_laboratory()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 41 | ! |
"Please use the `avalu_var` argument instead.", |
| 42 | ! |
call. = FALSE |
| 43 |
) |
|
| 44 |
} |
|
| 45 | ||
| 46 | ! |
checkmate::assert_string(dataname) |
| 47 | ! |
checkmate::assert_string(paramcd) |
| 48 | ! |
checkmate::assert_string(param) |
| 49 | ! |
checkmate::assert_string(anrind) |
| 50 | ! |
checkmate::assert_string(timepoints) |
| 51 | ! |
checkmate::assert_string(aval_var) |
| 52 | ! |
checkmate::assert_string(avalu_var) |
| 53 | ! |
checkmate::assert_integer(round_value, lower = 0) |
| 54 | ||
| 55 | ! |
y <- list() |
| 56 | ! |
y$table <- list() |
| 57 | ||
| 58 | ! |
table_lab_list <- add_expr( |
| 59 | ! |
list(), |
| 60 | ! |
substitute( |
| 61 | ! |
expr = {
|
| 62 | ! |
dataname[, aval_char] <- round(dataname[, aval_char], round_value) |
| 63 | ! |
labor_table_base <- dataname %>% |
| 64 | ! |
dplyr::select(timepoints, paramcd, param, aval_var, avalu_var, anrind) %>% |
| 65 | ! |
dplyr::arrange(timepoints) %>% |
| 66 | ! |
dplyr::select(-timepoints) %>% |
| 67 | ! |
dplyr::group_by(paramcd, param) %>% |
| 68 | ! |
dplyr::mutate(INDEX = dplyr::row_number()) %>% |
| 69 | ! |
dplyr::ungroup() %>% |
| 70 | ! |
dplyr::mutate(aval_anrind = paste(aval_var, anrind)) %>% |
| 71 | ! |
dplyr::select(-c(aval_var, anrind)) |
| 72 | ||
| 73 | ! |
labor_table_raw <- labor_table_base %>% |
| 74 | ! |
as.data.frame() %>% |
| 75 | ! |
stats::reshape( |
| 76 | ! |
direction = "wide", |
| 77 | ! |
idvar = c(paramcd_char, param_char, avalu_char), |
| 78 | ! |
v.names = "aval_anrind", |
| 79 | ! |
timevar = "INDEX" |
| 80 |
) |
|
| 81 | ! |
colnames(labor_table_raw)[-c(1:3)] <- unique(labor_table_base$INDEX) |
| 82 | ||
| 83 | ! |
labor_table_raw[[param_char]] <- clean_description(labor_table_raw[[param_char]]) |
| 84 | ||
| 85 | ! |
labor_table_raw <- rlistings::as_listing( |
| 86 | ! |
labor_table_raw, |
| 87 | ! |
key_cols = NULL, |
| 88 | ! |
default_formatting = list(all = fmt_config(align = "left")) |
| 89 |
) |
|
| 90 | ! |
main_title(labor_table_raw) <- paste("Patient ID:", patient_id)
|
| 91 | ||
| 92 | ! |
labor_table_html <- labor_table_base %>% |
| 93 | ! |
dplyr::mutate(aval_anrind_col = color_lab_values(aval_anrind)) %>% |
| 94 | ! |
dplyr::select(-aval_anrind) %>% |
| 95 | ! |
as.data.frame() %>% |
| 96 | ! |
stats::reshape( |
| 97 | ! |
direction = "wide", |
| 98 | ! |
idvar = c(paramcd_char, param_char, avalu_char), |
| 99 | ! |
v.names = "aval_anrind_col", |
| 100 | ! |
timevar = "INDEX" |
| 101 |
) |
|
| 102 | ! |
colnames(labor_table_html)[-c(1:3)] <- unique(labor_table_base$INDEX) |
| 103 | ! |
labor_table_html[[param_char]] <- clean_description(labor_table_html[[param_char]]) |
| 104 | ||
| 105 | ! |
labor_table_html_dt <- DT::datatable(labor_table_html, escape = FALSE) |
| 106 | ! |
labor_table_html_dt$dependencies <- c( |
| 107 | ! |
labor_table_html_dt$dependencies, |
| 108 | ! |
list(rmarkdown::html_dependency_bootstrap("default"))
|
| 109 |
) |
|
| 110 | ! |
labor_table_html_dt |
| 111 |
}, |
|
| 112 | ! |
env = list( |
| 113 | ! |
dataname = as.name(dataname), |
| 114 | ! |
param = as.name(param), |
| 115 | ! |
param_char = param, |
| 116 | ! |
paramcd = as.name(paramcd), |
| 117 | ! |
paramcd_char = paramcd, |
| 118 | ! |
aval_var = as.name(aval_var), |
| 119 | ! |
aval_char = aval_var, |
| 120 | ! |
avalu_var = as.name(avalu_var), |
| 121 | ! |
avalu_char = avalu_var, |
| 122 | ! |
timepoints = as.name(timepoints), |
| 123 | ! |
anrind = as.name(anrind), |
| 124 | ! |
patient_id = patient_id, |
| 125 | ! |
round_value = round_value |
| 126 |
) |
|
| 127 |
) |
|
| 128 |
) |
|
| 129 | ||
| 130 | ! |
y$table <- bracket_expr(table_lab_list) |
| 131 | ! |
y |
| 132 |
} |
|
| 133 | ||
| 134 |
#' teal Module: Patient Profile Laboratory Table |
|
| 135 |
#' |
|
| 136 |
#' This module produces a patient profile laboratory table using ADaM datasets. |
|
| 137 |
#' |
|
| 138 |
#' @inheritParams module_arguments |
|
| 139 |
#' @inheritParams template_laboratory |
|
| 140 |
#' @param param ([teal.transform::choices_selected()])\cr object with all |
|
| 141 |
#' available choices and preselected option for the `PARAM` variable from `dataname`. |
|
| 142 |
#' @param timepoints ([teal.transform::choices_selected()])\cr object with all |
|
| 143 |
#' available choices and preselected option for the time variable from `dataname`. |
|
| 144 |
#' @param anrind ([teal.transform::choices_selected()])\cr object with all |
|
| 145 |
#' available choices and preselected option for the `ANRIND` variable from `dataname`. Variable should have the |
|
| 146 |
#' following 3 levels: `"HIGH"`, `"LOW"`, and `"NORMAL"`. |
|
| 147 |
#' |
|
| 148 |
#' @inherit module_arguments return |
|
| 149 |
#' |
|
| 150 |
#' @examples |
|
| 151 |
#' ADSL <- tmc_ex_adsl |
|
| 152 |
#' ADLB <- tmc_ex_adlb |
|
| 153 |
#' |
|
| 154 |
#' app <- init( |
|
| 155 |
#' data = cdisc_data( |
|
| 156 |
#' ADSL = ADSL, |
|
| 157 |
#' ADLB = ADLB, |
|
| 158 |
#' code = " |
|
| 159 |
#' ADSL <- tmc_ex_adsl |
|
| 160 |
#' ADLB <- tmc_ex_adlb |
|
| 161 |
#' " |
|
| 162 |
#' ), |
|
| 163 |
#' modules = modules( |
|
| 164 |
#' tm_t_pp_laboratory( |
|
| 165 |
#' label = "Vitals", |
|
| 166 |
#' dataname = "ADLB", |
|
| 167 |
#' patient_col = "USUBJID", |
|
| 168 |
#' paramcd = choices_selected( |
|
| 169 |
#' choices = variable_choices(ADLB, "PARAMCD"), |
|
| 170 |
#' selected = "PARAMCD" |
|
| 171 |
#' ), |
|
| 172 |
#' param = choices_selected( |
|
| 173 |
#' choices = variable_choices(ADLB, "PARAM"), |
|
| 174 |
#' selected = "PARAM" |
|
| 175 |
#' ), |
|
| 176 |
#' timepoints = choices_selected( |
|
| 177 |
#' choices = variable_choices(ADLB, "ADY"), |
|
| 178 |
#' selected = "ADY" |
|
| 179 |
#' ), |
|
| 180 |
#' anrind = choices_selected( |
|
| 181 |
#' choices = variable_choices(ADLB, "ANRIND"), |
|
| 182 |
#' selected = "ANRIND" |
|
| 183 |
#' ), |
|
| 184 |
#' aval_var = choices_selected( |
|
| 185 |
#' choices = variable_choices(ADLB, "AVAL"), |
|
| 186 |
#' selected = "AVAL" |
|
| 187 |
#' ), |
|
| 188 |
#' avalu_var = choices_selected( |
|
| 189 |
#' choices = variable_choices(ADLB, "AVALU"), |
|
| 190 |
#' selected = "AVALU" |
|
| 191 |
#' ) |
|
| 192 |
#' ) |
|
| 193 |
#' ) |
|
| 194 |
#' ) |
|
| 195 |
#' if (interactive()) {
|
|
| 196 |
#' shinyApp(app$ui, app$server) |
|
| 197 |
#' } |
|
| 198 |
#' |
|
| 199 |
#' @export |
|
| 200 |
tm_t_pp_laboratory <- function(label, |
|
| 201 |
dataname = "ADLB", |
|
| 202 |
parentname = "ADSL", |
|
| 203 |
patient_col = "USUBJID", |
|
| 204 |
timepoints = NULL, |
|
| 205 |
aval = lifecycle::deprecated(), |
|
| 206 |
aval_var = NULL, |
|
| 207 |
avalu = lifecycle::deprecated(), |
|
| 208 |
avalu_var = NULL, |
|
| 209 |
param = NULL, |
|
| 210 |
paramcd = NULL, |
|
| 211 |
anrind = NULL, |
|
| 212 |
pre_output = NULL, |
|
| 213 |
post_output = NULL) {
|
|
| 214 | ! |
if (lifecycle::is_present(aval)) {
|
| 215 | ! |
aval_var <- aval |
| 216 | ! |
warning( |
| 217 | ! |
"The `aval` argument of `tm_t_pp_laboratory()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 218 | ! |
"Please use the `aval_var` argument instead.", |
| 219 | ! |
call. = FALSE |
| 220 |
) |
|
| 221 |
} else {
|
|
| 222 | ! |
aval <- aval_var # resolves missing argument error |
| 223 |
} |
|
| 224 | ||
| 225 | ! |
if (lifecycle::is_present(avalu)) {
|
| 226 | ! |
avalu_var <- avalu |
| 227 | ! |
warning( |
| 228 | ! |
"The `avalu` argument of `tm_t_pp_laboratory()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 229 | ! |
"Please use the `avalu_var` argument instead.", |
| 230 | ! |
call. = FALSE |
| 231 |
) |
|
| 232 |
} else {
|
|
| 233 | ! |
avalu <- avalu_var # resolves missing argument error |
| 234 |
} |
|
| 235 | ||
| 236 | ! |
message("Initializing tm_t_pp_laboratory")
|
| 237 | ! |
checkmate::assert_string(label) |
| 238 | ! |
checkmate::assert_string(dataname) |
| 239 | ! |
checkmate::assert_string(parentname) |
| 240 | ! |
checkmate::assert_string(patient_col) |
| 241 | ! |
checkmate::assert_class(timepoints, "choices_selected", null.ok = TRUE) |
| 242 | ! |
checkmate::assert_class(aval_var, "choices_selected", null.ok = TRUE) |
| 243 | ! |
checkmate::assert_class(avalu_var, "choices_selected", null.ok = TRUE) |
| 244 | ! |
checkmate::assert_class(param, "choices_selected", null.ok = TRUE) |
| 245 | ! |
checkmate::assert_class(paramcd, "choices_selected", null.ok = TRUE) |
| 246 | ! |
checkmate::assert_class(anrind, "choices_selected", null.ok = TRUE) |
| 247 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 248 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 249 | ||
| 250 | ! |
args <- as.list(environment()) |
| 251 | ! |
data_extract_list <- list( |
| 252 | ! |
timepoints = `if`(is.null(timepoints), NULL, cs_to_des_select(timepoints, dataname = dataname)), |
| 253 | ! |
aval_var = `if`(is.null(aval_var), NULL, cs_to_des_select(aval_var, dataname = dataname)), |
| 254 | ! |
avalu_var = `if`(is.null(avalu_var), NULL, cs_to_des_select(avalu_var, dataname = dataname)), |
| 255 | ! |
param = `if`(is.null(param), NULL, cs_to_des_select(param, dataname = dataname)), |
| 256 | ! |
paramcd = `if`(is.null(paramcd), NULL, cs_to_des_select(paramcd, dataname = dataname)), |
| 257 | ! |
anrind = `if`(is.null(anrind), NULL, cs_to_des_select(anrind, dataname = dataname)) |
| 258 |
) |
|
| 259 | ||
| 260 | ! |
module( |
| 261 | ! |
label = label, |
| 262 | ! |
ui = ui_g_laboratory, |
| 263 | ! |
ui_args = c(data_extract_list, args), |
| 264 | ! |
server = srv_g_laboratory, |
| 265 | ! |
server_args = c( |
| 266 | ! |
data_extract_list, |
| 267 | ! |
list( |
| 268 | ! |
dataname = dataname, |
| 269 | ! |
parentname = parentname, |
| 270 | ! |
label = label, |
| 271 | ! |
patient_col = patient_col |
| 272 |
) |
|
| 273 |
), |
|
| 274 | ! |
datanames = c(dataname, parentname) |
| 275 |
) |
|
| 276 |
} |
|
| 277 | ||
| 278 |
#' @keywords internal |
|
| 279 |
ui_g_laboratory <- function(id, ...) {
|
|
| 280 | ! |
ui_args <- list(...) |
| 281 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 282 | ! |
ui_args$timepoints, |
| 283 | ! |
ui_args$aval_var, |
| 284 | ! |
ui_args$avalu_var, |
| 285 | ! |
ui_args$param, |
| 286 | ! |
ui_args$paramcd, |
| 287 | ! |
ui_args$anrind |
| 288 |
) |
|
| 289 | ||
| 290 | ! |
ns <- NS(id) |
| 291 | ! |
teal.widgets::standard_layout( |
| 292 | ! |
output = tags$div( |
| 293 | ! |
htmlOutput(ns("title")),
|
| 294 | ! |
DT::DTOutput(outputId = ns("lab_values_table"))
|
| 295 |
), |
|
| 296 | ! |
encoding = tags$div( |
| 297 |
### Reporter |
|
| 298 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 299 |
### |
|
| 300 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 301 | ! |
teal.transform::datanames_input(ui_args[c("timepoints", "aval_var", "avalu_var", "param", "paramcd", "anrind")]),
|
| 302 | ! |
teal.widgets::optionalSelectInput( |
| 303 | ! |
ns("patient_id"),
|
| 304 | ! |
"Select Patient:", |
| 305 | ! |
multiple = FALSE, |
| 306 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 307 |
), |
|
| 308 | ! |
teal.transform::data_extract_ui( |
| 309 | ! |
id = ns("paramcd"),
|
| 310 | ! |
label = "Select PARAMCD variable:", |
| 311 | ! |
data_extract_spec = ui_args$paramcd, |
| 312 | ! |
is_single_dataset = is_single_dataset_value |
| 313 |
), |
|
| 314 | ! |
teal.transform::data_extract_ui( |
| 315 | ! |
id = ns("param"),
|
| 316 | ! |
label = "Select PARAM variable:", |
| 317 | ! |
data_extract_spec = ui_args$param, |
| 318 | ! |
is_single_dataset = is_single_dataset_value |
| 319 |
), |
|
| 320 | ! |
teal.transform::data_extract_ui( |
| 321 | ! |
id = ns("timepoints"),
|
| 322 | ! |
label = "Select timepoints variable:", |
| 323 | ! |
data_extract_spec = ui_args$timepoints, |
| 324 | ! |
is_single_dataset = is_single_dataset_value |
| 325 |
), |
|
| 326 | ! |
teal.transform::data_extract_ui( |
| 327 | ! |
id = ns("aval_var"),
|
| 328 | ! |
label = "Select AVAL variable:", |
| 329 | ! |
data_extract_spec = ui_args$aval_var, |
| 330 | ! |
is_single_dataset = is_single_dataset_value |
| 331 |
), |
|
| 332 | ! |
teal.transform::data_extract_ui( |
| 333 | ! |
id = ns("avalu_var"),
|
| 334 | ! |
label = "Select AVALU variable:", |
| 335 | ! |
data_extract_spec = ui_args$avalu_var, |
| 336 | ! |
is_single_dataset = is_single_dataset_value |
| 337 |
), |
|
| 338 | ! |
teal.transform::data_extract_ui( |
| 339 | ! |
id = ns("anrind"),
|
| 340 | ! |
label = "Select ANRIND variable:", |
| 341 | ! |
data_extract_spec = ui_args$anrind, |
| 342 | ! |
is_single_dataset = is_single_dataset_value |
| 343 |
), |
|
| 344 | ! |
selectInput( |
| 345 | ! |
inputId = ns("round_value"),
|
| 346 | ! |
label = "Select number of decimal places for rounding:", |
| 347 | ! |
choices = NULL |
| 348 |
) |
|
| 349 |
), |
|
| 350 | ! |
forms = tagList( |
| 351 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 352 |
), |
|
| 353 | ! |
pre_output = ui_args$pre_output, |
| 354 | ! |
post_output = ui_args$post_output |
| 355 |
) |
|
| 356 |
} |
|
| 357 | ||
| 358 |
#' @keywords internal |
|
| 359 |
srv_g_laboratory <- function(id, |
|
| 360 |
data, |
|
| 361 |
reporter, |
|
| 362 |
filter_panel_api, |
|
| 363 |
dataname, |
|
| 364 |
parentname, |
|
| 365 |
patient_col, |
|
| 366 |
timepoints, |
|
| 367 |
aval_var, |
|
| 368 |
avalu_var, |
|
| 369 |
param, |
|
| 370 |
paramcd, |
|
| 371 |
anrind, |
|
| 372 |
label) {
|
|
| 373 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 374 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 375 | ! |
checkmate::assert_class(data, "reactive") |
| 376 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 377 | ||
| 378 | ! |
moduleServer(id, function(input, output, session) {
|
| 379 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 380 | ! |
patient_id <- reactive(input$patient_id) |
| 381 | ||
| 382 |
# Init |
|
| 383 | ! |
patient_data_base <- reactive(unique(data()[[parentname]][[patient_col]])) |
| 384 | ! |
teal.widgets::updateOptionalSelectInput( |
| 385 | ! |
session, |
| 386 | ! |
"patient_id", |
| 387 | ! |
choices = patient_data_base(), |
| 388 | ! |
selected = patient_data_base()[1] |
| 389 |
) |
|
| 390 | ||
| 391 | ! |
observeEvent(patient_data_base(), |
| 392 | ! |
handlerExpr = {
|
| 393 | ! |
teal.widgets::updateOptionalSelectInput( |
| 394 | ! |
session, |
| 395 | ! |
"patient_id", |
| 396 | ! |
choices = patient_data_base(), |
| 397 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 398 | ! |
patient_data_base() |
| 399 |
} else {
|
|
| 400 | ! |
intersect(patient_id(), patient_data_base()) |
| 401 |
} |
|
| 402 |
) |
|
| 403 |
}, |
|
| 404 | ! |
ignoreInit = TRUE |
| 405 |
) |
|
| 406 | ||
| 407 |
# Update round_values |
|
| 408 | ! |
aval_values <- isolate(data())[[dataname]][, aval_var$select$selected] |
| 409 | ! |
decimal_nums <- aval_values[trunc(aval_values) != aval_values] |
| 410 | ! |
max_decimal <- max(nchar(gsub("([0-9]+).([0-9]+)", "\\2", decimal_nums)))
|
| 411 | ||
| 412 | ! |
updateSelectInput( |
| 413 | ! |
session, |
| 414 | ! |
"round_value", |
| 415 | ! |
choices = seq(0, max_decimal), |
| 416 | ! |
selected = min(4, max_decimal) |
| 417 |
) |
|
| 418 | ||
| 419 |
# Laboratory values tab ---- |
|
| 420 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 421 | ! |
data_extract = list( |
| 422 | ! |
timepoints = timepoints, |
| 423 | ! |
aval_var = aval_var, |
| 424 | ! |
avalu_var = avalu_var, |
| 425 | ! |
param = param, |
| 426 | ! |
paramcd = paramcd, |
| 427 | ! |
anrind = anrind |
| 428 |
), |
|
| 429 | ! |
datasets = data, |
| 430 | ! |
select_validation_rule = list( |
| 431 | ! |
timepoints = shinyvalidate::sv_required("Please select timepoints variable."),
|
| 432 | ! |
aval_var = shinyvalidate::sv_required("Please select AVAL variable."),
|
| 433 | ! |
avalu_var = shinyvalidate::sv_required("Please select AVALU variable."),
|
| 434 | ! |
param = shinyvalidate::sv_required("Please select PARAM variable."),
|
| 435 | ! |
paramcd = shinyvalidate::sv_required("Please select PARAMCD variable."),
|
| 436 | ! |
anrind = shinyvalidate::sv_required("Please select ANRIND variable.")
|
| 437 |
) |
|
| 438 |
) |
|
| 439 | ||
| 440 | ! |
iv_r <- reactive({
|
| 441 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 442 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient"))
|
| 443 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 444 |
}) |
|
| 445 | ||
| 446 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 447 | ! |
datasets = data, |
| 448 | ! |
selector_list = selector_list |
| 449 |
) |
|
| 450 | ||
| 451 | ! |
anl_q <- reactive({
|
| 452 | ! |
data() %>% |
| 453 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 454 |
}) |
|
| 455 | ||
| 456 | ! |
all_q <- reactive({
|
| 457 | ! |
teal::validate_inputs(iv_r()) |
| 458 | ||
| 459 | ! |
labor_calls <- template_laboratory( |
| 460 | ! |
dataname = "ANL", |
| 461 | ! |
timepoints = input[[extract_input("timepoints", dataname)]],
|
| 462 | ! |
aval_var = input[[extract_input("aval_var", dataname)]],
|
| 463 | ! |
avalu_var = input[[extract_input("avalu_var", dataname)]],
|
| 464 | ! |
param = input[[extract_input("param", dataname)]],
|
| 465 | ! |
paramcd = input[[extract_input("paramcd", dataname)]],
|
| 466 | ! |
anrind = input[[extract_input("anrind", dataname)]],
|
| 467 | ! |
patient_id = patient_id(), |
| 468 | ! |
round_value = as.integer(input$round_value) |
| 469 |
) |
|
| 470 | ||
| 471 | ! |
teal.code::eval_code( |
| 472 | ! |
anl_q(), |
| 473 | ! |
substitute( |
| 474 | ! |
expr = {
|
| 475 | ! |
pt_id <- patient_id |
| 476 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 477 | ! |
}, env = list( |
| 478 | ! |
patient_col = patient_col, |
| 479 | ! |
patient_id = patient_id() |
| 480 |
) |
|
| 481 |
) |
|
| 482 |
) %>% |
|
| 483 | ! |
teal.code::eval_code(as.expression(labor_calls)) |
| 484 |
}) |
|
| 485 | ||
| 486 | ! |
output$title <- renderText({
|
| 487 | ! |
paste("<h5><b>Patient ID:", all_q()[["pt_id"]], "</b></h5>")
|
| 488 |
}) |
|
| 489 | ||
| 490 | ! |
table_r <- reactive({
|
| 491 | ! |
q <- all_q() |
| 492 | ! |
list( |
| 493 | ! |
html = q[["labor_table_html"]], |
| 494 | ! |
raw = q[["labor_table_raw"]] |
| 495 |
) |
|
| 496 |
}) |
|
| 497 | ||
| 498 | ! |
output$lab_values_table <- DT::renderDataTable( |
| 499 | ! |
expr = table_r()$html, |
| 500 | ! |
escape = FALSE, |
| 501 | ! |
options = list( |
| 502 | ! |
lengthMenu = list(list(-1, 5, 10, 25), list("All", "5", "10", "25")),
|
| 503 | ! |
scrollX = TRUE |
| 504 |
) |
|
| 505 |
) |
|
| 506 | ||
| 507 | ! |
teal.widgets::verbatim_popup_srv( |
| 508 | ! |
id = "rcode", |
| 509 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 510 | ! |
title = label |
| 511 |
) |
|
| 512 | ||
| 513 |
### REPORTER |
|
| 514 | ! |
if (with_reporter) {
|
| 515 | ! |
card_fun <- function(comment, label) {
|
| 516 | ! |
card <- teal::report_card_template( |
| 517 | ! |
title = "Patient Profile Laboratory Table", |
| 518 | ! |
label = label, |
| 519 | ! |
with_filter = with_filter, |
| 520 | ! |
filter_panel_api = filter_panel_api |
| 521 |
) |
|
| 522 | ! |
card$append_text("Table", "header3")
|
| 523 | ! |
card$append_table(table_r()$raw) |
| 524 | ! |
if (!comment == "") {
|
| 525 | ! |
card$append_text("Comment", "header3")
|
| 526 | ! |
card$append_text(comment) |
| 527 |
} |
|
| 528 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 529 | ! |
card |
| 530 |
} |
|
| 531 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 532 |
} |
|
| 533 |
### |
|
| 534 |
}) |
|
| 535 |
} |
| 1 |
#' Template: Summary of Variables |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table to summarize variables. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param show_labels `r lifecycle::badge("deprecated")`
|
|
| 7 |
#' @param arm_var_labels (`character` or `NULL`)\cr vector of column variable labels to display, of the same length as |
|
| 8 |
#' `arm_var`. If `NULL`, no labels will be displayed. |
|
| 9 |
#' |
|
| 10 |
#' @inherit template_arguments return |
|
| 11 |
#' |
|
| 12 |
#' @seealso [tm_t_summary()] |
|
| 13 |
#' |
|
| 14 |
#' @keywords internal |
|
| 15 |
template_summary <- function(dataname, |
|
| 16 |
parentname, |
|
| 17 |
arm_var, |
|
| 18 |
sum_vars, |
|
| 19 |
show_labels = lifecycle::deprecated(), |
|
| 20 |
add_total = TRUE, |
|
| 21 |
total_label = default_total_label(), |
|
| 22 |
var_labels = character(), |
|
| 23 |
arm_var_labels = NULL, |
|
| 24 |
na.rm = FALSE, # nolint: object_name. |
|
| 25 |
na_level = default_na_str(), |
|
| 26 |
numeric_stats = c( |
|
| 27 |
"n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", "range", "geom_mean" |
|
| 28 |
), |
|
| 29 |
denominator = c("N", "n", "omit"),
|
|
| 30 |
drop_arm_levels = TRUE, |
|
| 31 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 32 | 6x |
if (lifecycle::is_present(show_labels)) {
|
| 33 | ! |
warning( |
| 34 | ! |
"The `show_labels` argument of `template_summary` is deprecated as of teal.modules.clinical 0.9.1.9013 ", |
| 35 | ! |
"as it is has no effect on the module.", |
| 36 | ! |
call. = FALSE |
| 37 |
) |
|
| 38 |
} |
|
| 39 | ||
| 40 | 6x |
checkmate::assert_string(dataname) |
| 41 | 6x |
checkmate::assert_string(parentname) |
| 42 | 6x |
checkmate::assert_character(arm_var, min.len = 1, max.len = 2) |
| 43 | 6x |
checkmate::assert_character(sum_vars) |
| 44 | 6x |
checkmate::assert_flag(add_total) |
| 45 | 6x |
checkmate::assert_string(total_label) |
| 46 | 6x |
checkmate::assert_character(var_labels) |
| 47 | 6x |
checkmate::assert_character(arm_var_labels, len = length(arm_var), null.ok = TRUE) |
| 48 | 6x |
checkmate::assert_flag(na.rm) |
| 49 | 6x |
checkmate::assert_string(na_level) |
| 50 | 6x |
checkmate::assert_flag(drop_arm_levels) |
| 51 | 6x |
checkmate::assert_character(numeric_stats, min.len = 1) |
| 52 | 6x |
checkmate::assert_subset( |
| 53 | 6x |
numeric_stats, |
| 54 | 6x |
c("n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", "range", "geom_mean")
|
| 55 |
) |
|
| 56 | ||
| 57 | 6x |
denominator <- match.arg(denominator) |
| 58 | ||
| 59 | 6x |
y <- list() |
| 60 | ||
| 61 |
# Data processing |
|
| 62 | 6x |
data_list <- list() |
| 63 | ||
| 64 | 6x |
data_list <- add_expr( |
| 65 | 6x |
data_list, |
| 66 | 6x |
substitute( |
| 67 | 6x |
expr = anl <- df %>% |
| 68 | 6x |
df_explicit_na(omit_columns = setdiff(names(df), c(sum_vars)), na_level = na_str), |
| 69 | 6x |
env = list( |
| 70 | 6x |
df = as.name(dataname), |
| 71 | 6x |
sum_vars = sum_vars, |
| 72 | 6x |
na_str = na_level |
| 73 |
) |
|
| 74 |
) |
|
| 75 |
) |
|
| 76 | ||
| 77 | 6x |
prepare_arm_levels_call <- lapply(arm_var, function(x) {
|
| 78 | 10x |
prepare_arm_levels( |
| 79 | 10x |
dataname = "anl", |
| 80 | 10x |
parentname = parentname, |
| 81 | 10x |
arm_var = x, |
| 82 | 10x |
drop_arm_levels = drop_arm_levels |
| 83 |
) |
|
| 84 |
}) |
|
| 85 | 6x |
data_list <- Reduce(add_expr, prepare_arm_levels_call, init = data_list) |
| 86 | ||
| 87 | 6x |
data_list <- add_expr( |
| 88 | 6x |
data_list, |
| 89 | 6x |
substitute( |
| 90 | 6x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 91 | 6x |
env = list( |
| 92 | 6x |
parentname = as.name(parentname), |
| 93 | 6x |
na_str = na_level |
| 94 |
) |
|
| 95 |
) |
|
| 96 |
) |
|
| 97 | ||
| 98 | 6x |
y$data <- bracket_expr(data_list) |
| 99 | ||
| 100 | 6x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 101 | 6x |
teal.widgets::resolve_basic_table_args( |
| 102 | 6x |
user_table = basic_table_args, |
| 103 | 6x |
module_table = teal.widgets::basic_table_args( |
| 104 | 6x |
show_colcounts = TRUE, |
| 105 | 6x |
main_footer = |
| 106 | 6x |
"n represents the number of unique subject IDs such that the variable has non-NA values." |
| 107 |
) |
|
| 108 |
) |
|
| 109 |
) |
|
| 110 | ||
| 111 | 6x |
layout_list <- list() |
| 112 | 6x |
layout_list <- add_expr( |
| 113 | 6x |
layout_list, |
| 114 | 6x |
parsed_basic_table_args |
| 115 |
) |
|
| 116 | ||
| 117 |
# Build layout |
|
| 118 | 6x |
split_cols_call <- lapply(arm_var, function(x) {
|
| 119 | 10x |
if (drop_arm_levels) {
|
| 120 | 9x |
substitute( |
| 121 | 9x |
expr = rtables::split_cols_by(x, split_fun = drop_split_levels), |
| 122 | 9x |
env = list(x = x) |
| 123 |
) |
|
| 124 |
} else {
|
|
| 125 | 1x |
substitute( |
| 126 | 1x |
expr = rtables::split_cols_by(x), |
| 127 | 1x |
env = list(x = x) |
| 128 |
) |
|
| 129 |
} |
|
| 130 |
}) |
|
| 131 | 6x |
layout_list <- Reduce(add_expr, split_cols_call, init = layout_list) |
| 132 | ||
| 133 | 6x |
if (add_total) {
|
| 134 | 3x |
layout_list <- add_expr( |
| 135 | 3x |
layout_list, |
| 136 | 3x |
substitute( |
| 137 | 3x |
expr = rtables::add_overall_col(total_label), |
| 138 | 3x |
env = list(total_label = total_label) |
| 139 |
) |
|
| 140 |
) |
|
| 141 |
} |
|
| 142 | ||
| 143 | 6x |
env_sum_vars <- list( |
| 144 | 6x |
sum_vars = sum_vars, |
| 145 | 6x |
sum_var_labels = var_labels[sum_vars], |
| 146 | 6x |
na.rm = na.rm, |
| 147 | 6x |
na_level = na_level, |
| 148 | 6x |
denom = ifelse(denominator == "n", "n", "N_col"), |
| 149 | 6x |
stats = c( |
| 150 | 6x |
numeric_stats, |
| 151 | 6x |
ifelse(denominator == "omit", "count", "count_fraction") |
| 152 |
) |
|
| 153 |
) |
|
| 154 | ||
| 155 | 6x |
layout_list <- add_expr( |
| 156 | 6x |
layout_list, |
| 157 | 6x |
if (length(var_labels) > 0) {
|
| 158 | 1x |
substitute( |
| 159 | 1x |
expr = analyze_vars( |
| 160 | 1x |
vars = sum_vars, |
| 161 | 1x |
var_labels = sum_var_labels, |
| 162 | 1x |
show_labels = "visible", |
| 163 | 1x |
na.rm = na.rm, |
| 164 | 1x |
na_str = na_level, |
| 165 | 1x |
denom = denom, |
| 166 | 1x |
.stats = stats |
| 167 |
), |
|
| 168 | 1x |
env = env_sum_vars |
| 169 |
) |
|
| 170 |
} else {
|
|
| 171 | 5x |
substitute( |
| 172 | 5x |
expr = analyze_vars( |
| 173 | 5x |
vars = sum_vars, |
| 174 | 5x |
show_labels = "visible", |
| 175 | 5x |
na.rm = na.rm, |
| 176 | 5x |
na_str = na_level, |
| 177 | 5x |
denom = denom, |
| 178 | 5x |
.stats = stats |
| 179 |
), |
|
| 180 | 5x |
env = env_sum_vars |
| 181 |
) |
|
| 182 |
} |
|
| 183 |
) |
|
| 184 | ||
| 185 | 6x |
if (!is.null(arm_var_labels)) {
|
| 186 | 1x |
layout_list <- add_expr( |
| 187 | 1x |
layout_list, |
| 188 | 1x |
substitute( |
| 189 | 1x |
expr = append_topleft(arm_var_labels), |
| 190 | 1x |
env = list(arm_var_labels = c(arm_var_labels, "")) |
| 191 |
) |
|
| 192 |
) |
|
| 193 |
} |
|
| 194 | ||
| 195 | 6x |
y$layout <- substitute( |
| 196 | 6x |
expr = lyt <- layout_pipe, |
| 197 | 6x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 198 |
) |
|
| 199 | ||
| 200 | 6x |
y$table <- substitute( |
| 201 | 6x |
expr = {
|
| 202 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 203 | ! |
result |
| 204 |
}, |
|
| 205 | 6x |
env = list(parent = as.name(parentname)) |
| 206 |
) |
|
| 207 | ||
| 208 | 6x |
y |
| 209 |
} |
|
| 210 | ||
| 211 |
#' teal Module: Summary of Variables |
|
| 212 |
#' |
|
| 213 |
#' This module produces a table to summarize variables. |
|
| 214 |
#' |
|
| 215 |
#' @inheritParams module_arguments |
|
| 216 |
#' @inheritParams template_summary |
|
| 217 |
#' @param arm_var ([teal.transform::choices_selected()])\cr object with all |
|
| 218 |
#' available choices and preselected option for variable names that can be used as `arm_var`. |
|
| 219 |
#' It defines the grouping variable(s) in the results table. |
|
| 220 |
#' If there are two elements selected for `arm_var`, |
|
| 221 |
#' second variable will be nested under the first variable. |
|
| 222 |
#' @param show_arm_var_labels (`flag`)\cr whether arm variable label(s) should be displayed. Defaults to `TRUE`. |
|
| 223 |
#' |
|
| 224 |
#' @inherit module_arguments return seealso |
|
| 225 |
#' |
|
| 226 |
#' @examples |
|
| 227 |
#' # Preparation of the test case - use `EOSDY` and `DCSREAS` variables to demonstrate missing data. |
|
| 228 |
#' ADSL <- tmc_ex_adsl |
|
| 229 |
#' ADSL$EOSDY[1] <- NA_integer_ |
|
| 230 |
#' |
|
| 231 |
#' app <- init( |
|
| 232 |
#' data = cdisc_data( |
|
| 233 |
#' ADSL = ADSL, |
|
| 234 |
#' code = " |
|
| 235 |
#' ADSL <- tmc_ex_adsl |
|
| 236 |
#' ADSL$EOSDY[1] <- NA_integer_ |
|
| 237 |
#' " |
|
| 238 |
#' ), |
|
| 239 |
#' modules = modules( |
|
| 240 |
#' tm_t_summary( |
|
| 241 |
#' label = "Demographic Table", |
|
| 242 |
#' dataname = "ADSL", |
|
| 243 |
#' arm_var = choices_selected(c("ARM", "ARMCD"), "ARM"),
|
|
| 244 |
#' add_total = TRUE, |
|
| 245 |
#' summarize_vars = choices_selected( |
|
| 246 |
#' c("SEX", "RACE", "BMRKR2", "EOSDY", "DCSREAS", "AGE"),
|
|
| 247 |
#' c("SEX", "RACE")
|
|
| 248 |
#' ), |
|
| 249 |
#' useNA = "ifany" |
|
| 250 |
#' ) |
|
| 251 |
#' ) |
|
| 252 |
#' ) |
|
| 253 |
#' if (interactive()) {
|
|
| 254 |
#' shinyApp(app$ui, app$server) |
|
| 255 |
#' } |
|
| 256 |
#' |
|
| 257 |
#' @export |
|
| 258 |
tm_t_summary <- function(label, |
|
| 259 |
dataname, |
|
| 260 |
parentname = ifelse( |
|
| 261 |
inherits(arm_var, "data_extract_spec"), |
|
| 262 |
teal.transform::datanames_input(arm_var), |
|
| 263 |
"ADSL" |
|
| 264 |
), |
|
| 265 |
arm_var, |
|
| 266 |
summarize_vars, |
|
| 267 |
add_total = TRUE, |
|
| 268 |
total_label = default_total_label(), |
|
| 269 |
show_arm_var_labels = TRUE, |
|
| 270 |
useNA = c("ifany", "no"), # nolint: object_name.
|
|
| 271 |
na_level = default_na_str(), |
|
| 272 |
numeric_stats = c( |
|
| 273 |
"n", "mean_sd", "mean_ci", "median", "median_ci", "quantiles", "range", "geom_mean" |
|
| 274 |
), |
|
| 275 |
denominator = c("N", "n", "omit"),
|
|
| 276 |
drop_arm_levels = TRUE, |
|
| 277 |
pre_output = NULL, |
|
| 278 |
post_output = NULL, |
|
| 279 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 280 | ! |
message("Initializing tm_t_summary")
|
| 281 | ! |
checkmate::assert_string(label) |
| 282 | ! |
checkmate::assert_string(dataname) |
| 283 | ! |
checkmate::assert_string(parentname) |
| 284 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 285 | ! |
checkmate::assert_class(summarize_vars, "choices_selected") |
| 286 | ! |
checkmate::assert_string(na_level) |
| 287 | ! |
checkmate::assert_character(numeric_stats, min.len = 1) |
| 288 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 289 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 290 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 291 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 292 | ! |
checkmate::assert_flag(add_total) |
| 293 | ! |
checkmate::assert_flag(show_arm_var_labels) |
| 294 | ! |
checkmate::assert_string(total_label) |
| 295 | ||
| 296 | ! |
useNA <- match.arg(useNA) # nolint: object_name. |
| 297 | ! |
denominator <- match.arg(denominator) |
| 298 | ! |
numeric_stats <- match.arg(numeric_stats, several.ok = TRUE) |
| 299 | ||
| 300 | ! |
args <- as.list(environment()) |
| 301 | ||
| 302 | ! |
data_extract_list <- list( |
| 303 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 304 | ! |
summarize_vars = cs_to_des_select(summarize_vars, dataname = dataname, multiple = TRUE, ordered = TRUE) |
| 305 |
) |
|
| 306 | ||
| 307 | ! |
module( |
| 308 | ! |
label = label, |
| 309 | ! |
server = srv_summary, |
| 310 | ! |
ui = ui_summary, |
| 311 | ! |
ui_args = c(data_extract_list, args), |
| 312 | ! |
server_args = c( |
| 313 | ! |
data_extract_list, |
| 314 | ! |
list( |
| 315 | ! |
dataname = dataname, |
| 316 | ! |
parentname = parentname, |
| 317 | ! |
label = label, |
| 318 | ! |
show_arm_var_labels = show_arm_var_labels, |
| 319 | ! |
total_label = total_label, |
| 320 | ! |
na_level = na_level, |
| 321 | ! |
basic_table_args = basic_table_args |
| 322 |
) |
|
| 323 |
), |
|
| 324 | ! |
datanames = c(dataname, parentname) |
| 325 |
) |
|
| 326 |
} |
|
| 327 | ||
| 328 |
#' @keywords internal |
|
| 329 |
ui_summary <- function(id, ...) {
|
|
| 330 | ! |
ns <- NS(id) |
| 331 | ! |
a <- list(...) |
| 332 | ||
| 333 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset(a$arm_var, a$summarize_vars) |
| 334 | ||
| 335 | ! |
teal.widgets::standard_layout( |
| 336 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 337 | ! |
encoding = tags$div( |
| 338 |
### Reporter |
|
| 339 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 340 |
### |
|
| 341 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 342 | ! |
teal.transform::datanames_input(a[c("arm_var", "summarize_vars")]),
|
| 343 | ! |
teal.transform::data_extract_ui( |
| 344 | ! |
id = ns("arm_var"),
|
| 345 | ! |
label = "Select Column Variable(s)", |
| 346 | ! |
data_extract_spec = a$arm_var, |
| 347 | ! |
is_single_dataset = is_single_dataset_value |
| 348 |
), |
|
| 349 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total),
|
| 350 | ! |
teal.transform::data_extract_ui( |
| 351 | ! |
id = ns("summarize_vars"),
|
| 352 | ! |
label = "Summarize Variables", |
| 353 | ! |
data_extract_spec = a$summarize_vars, |
| 354 | ! |
is_single_dataset = is_single_dataset_value |
| 355 |
), |
|
| 356 | ! |
teal.widgets::panel_group( |
| 357 | ! |
teal.widgets::panel_item( |
| 358 | ! |
"Additional table settings", |
| 359 | ! |
radioButtons( |
| 360 | ! |
ns("useNA"),
|
| 361 | ! |
label = "Display NA counts", |
| 362 | ! |
choices = c("ifany", "no"),
|
| 363 | ! |
selected = a$useNA |
| 364 |
), |
|
| 365 | ! |
checkboxGroupInput( |
| 366 | ! |
ns("numeric_stats"),
|
| 367 | ! |
label = "Choose the statistics to display for numeric variables", |
| 368 | ! |
choices = c( |
| 369 | ! |
"n" = "n", |
| 370 | ! |
"Mean (SD)" = "mean_sd", |
| 371 | ! |
"Mean 95% CI" = "mean_ci", |
| 372 | ! |
"Geometric Mean" = "geom_mean", |
| 373 | ! |
"Median" = "median", |
| 374 | ! |
"Median 95% CI" = "median_ci", |
| 375 | ! |
"25% and 75%-ile" = "quantiles", |
| 376 | ! |
"Min - Max" = "range" |
| 377 |
), |
|
| 378 | ! |
selected = a$numeric_stats |
| 379 |
), |
|
| 380 | ! |
radioButtons( |
| 381 | ! |
ns("denominator"),
|
| 382 | ! |
label = "Denominator choice", |
| 383 | ! |
choices = c("N", "n", "omit"),
|
| 384 | ! |
selected = a$denominator |
| 385 |
), |
|
| 386 | ! |
if (a$dataname == a$parentname) {
|
| 387 | ! |
shinyjs::hidden( |
| 388 | ! |
checkboxInput( |
| 389 | ! |
ns("drop_arm_levels"),
|
| 390 | ! |
label = "it's a BUG if you see this", |
| 391 | ! |
value = TRUE |
| 392 |
) |
|
| 393 |
) |
|
| 394 |
} else {
|
|
| 395 | ! |
checkboxInput( |
| 396 | ! |
ns("drop_arm_levels"),
|
| 397 | ! |
label = sprintf("Drop columns not in filtered %s", a$dataname),
|
| 398 | ! |
value = a$drop_arm_levels |
| 399 |
) |
|
| 400 |
} |
|
| 401 |
) |
|
| 402 |
) |
|
| 403 |
), |
|
| 404 | ! |
forms = tagList( |
| 405 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 406 |
), |
|
| 407 | ! |
pre_output = a$pre_output, |
| 408 | ! |
post_output = a$post_output |
| 409 |
) |
|
| 410 |
} |
|
| 411 | ||
| 412 |
#' @keywords internal |
|
| 413 |
srv_summary <- function(id, |
|
| 414 |
data, |
|
| 415 |
reporter, |
|
| 416 |
filter_panel_api, |
|
| 417 |
dataname, |
|
| 418 |
parentname, |
|
| 419 |
arm_var, |
|
| 420 |
summarize_vars, |
|
| 421 |
add_total, |
|
| 422 |
show_arm_var_labels, |
|
| 423 |
total_label, |
|
| 424 |
na_level, |
|
| 425 |
drop_arm_levels, |
|
| 426 |
label, |
|
| 427 |
basic_table_args) {
|
|
| 428 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 429 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 430 | ! |
checkmate::assert_class(data, "reactive") |
| 431 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 432 | ! |
moduleServer(id, function(input, output, session) {
|
| 433 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 434 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 435 | ! |
data_extract = list(arm_var = arm_var, summarize_vars = summarize_vars), |
| 436 | ! |
datasets = data, |
| 437 | ! |
select_validation_rule = list( |
| 438 | ! |
summarize_vars = shinyvalidate::sv_required("Please select a summarize variable"),
|
| 439 | ! |
arm_var = ~ if (length(.) != 1 && length(.) != 2) {
|
| 440 | ! |
"Please select 1 or 2 column variables" |
| 441 |
} |
|
| 442 |
) |
|
| 443 |
) |
|
| 444 | ||
| 445 | ! |
iv_r <- reactive({
|
| 446 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 447 | ! |
iv$add_rule("numeric_stats", shinyvalidate::sv_required("Please select at least one statistic to display."))
|
| 448 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 449 |
}) |
|
| 450 | ||
| 451 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 452 | ! |
id = "anl_merge", |
| 453 | ! |
datasets = data, |
| 454 | ! |
selector_list = selector_list, |
| 455 | ! |
merge_function = "dplyr::inner_join" |
| 456 |
) |
|
| 457 | ||
| 458 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 459 | ! |
id = "adsl_merge", |
| 460 | ! |
datasets = data, |
| 461 | ! |
data_extract = list(arm_var = arm_var), |
| 462 | ! |
anl_name = "ANL_ADSL" |
| 463 |
) |
|
| 464 | ||
| 465 | ! |
anl_q <- reactive({
|
| 466 | ! |
data() %>% |
| 467 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 468 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 469 |
}) |
|
| 470 | ||
| 471 | ! |
merged <- list( |
| 472 | ! |
anl_input_r = anl_inputs, |
| 473 | ! |
adsl_input_r = adsl_inputs, |
| 474 | ! |
anl_q = anl_q |
| 475 |
) |
|
| 476 | ||
| 477 | ! |
observeEvent(merged$anl_input_r()$columns_source$summarize_vars, {
|
| 478 | ! |
choices_classes <- sapply( |
| 479 | ! |
names(merged$anl_input_r()$columns_source$summarize_vars), |
| 480 | ! |
function(x) {
|
| 481 | ! |
summarize_var_data <- data()[[summarize_vars$dataname]][[x]] |
| 482 | ! |
inherits(summarize_var_data, "numeric") | |
| 483 | ! |
inherits(summarize_var_data, "integer") |
| 484 |
} |
|
| 485 |
) |
|
| 486 | ||
| 487 | ! |
if (any(choices_classes)) {
|
| 488 | ! |
shinyjs::show("numeric_stats")
|
| 489 |
} else {
|
|
| 490 | ! |
shinyjs::hide("numeric_stats")
|
| 491 |
} |
|
| 492 |
}) |
|
| 493 | ||
| 494 |
# validate inputs |
|
| 495 | ! |
validate_checks <- reactive({
|
| 496 | ! |
teal::validate_inputs(iv_r()) |
| 497 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 498 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 499 | ! |
anl <- merged$anl_q()[["ANL"]] |
| 500 | ||
| 501 |
# we take names of the columns source as they match names of the input data in merge_datasets |
|
| 502 |
# if we use $arm_var they might be renamed to <selector id>.arm_var |
|
| 503 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 504 | ! |
input_summarize_vars <- names(merged$anl_input_r()$columns_source$summarize_vars) |
| 505 | ||
| 506 | ! |
validate( |
| 507 | ! |
need( |
| 508 | ! |
length(unique(anl$USUBJID)) == nrow(anl), |
| 509 | ! |
paste0( |
| 510 | ! |
"Please choose an analysis dataset where each row represents a different subject, ", |
| 511 | ! |
"i.e. USUBJID is different in each row" |
| 512 |
) |
|
| 513 |
), |
|
| 514 | ! |
need( |
| 515 | ! |
!any(vapply(anl_filtered[, input_summarize_vars], inherits, c("Date", "POSIXt"),
|
| 516 | ! |
FUN.VALUE = logical(1) |
| 517 |
)), |
|
| 518 | ! |
"Date and POSIXt variables are not supported, please select other variables" |
| 519 |
), |
|
| 520 | ! |
if (length(input_arm_var) == 2) {
|
| 521 | ! |
need( |
| 522 | ! |
is.factor(adsl_filtered[[input_arm_var[[2]]]]) & all(!adsl_filtered[[input_arm_var[[2]]]] %in% c("", NA)),
|
| 523 | ! |
"Please check nested treatment variable which needs to be a factor without NA or empty strings." |
| 524 |
) |
|
| 525 |
} |
|
| 526 |
) |
|
| 527 | ||
| 528 | ! |
validate_standard_inputs( |
| 529 | ! |
adsl = adsl_filtered, |
| 530 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 531 | ! |
anl = anl_filtered, |
| 532 | ! |
anlvars = c("USUBJID", "STUDYID", input_summarize_vars),
|
| 533 | ! |
arm_var = input_arm_var[[1]] |
| 534 |
) |
|
| 535 |
}) |
|
| 536 | ||
| 537 |
# generate r code for the analysis |
|
| 538 | ! |
all_q <- reactive({
|
| 539 | ! |
validate_checks() |
| 540 | ||
| 541 | ! |
summarize_vars <- merged$anl_input_r()$columns_source$summarize_vars |
| 542 | ! |
var_labels <- teal.data::col_labels(data()[[dataname]][, summarize_vars, drop = FALSE]) |
| 543 | ||
| 544 | ! |
arm_var_labels <- NULL |
| 545 | ! |
if (show_arm_var_labels) {
|
| 546 | ! |
arm_vars <- merged$anl_input_r()$columns_source$arm_var |
| 547 | ! |
arm_var_labels <- teal.data::col_labels(data()[[dataname]][, arm_vars, drop = FALSE], fill = TRUE) |
| 548 |
} |
|
| 549 | ||
| 550 | ! |
my_calls <- template_summary( |
| 551 | ! |
dataname = "ANL", |
| 552 | ! |
parentname = "ANL_ADSL", |
| 553 | ! |
arm_var = merged$anl_input_r()$columns_source$arm_var, |
| 554 | ! |
sum_vars = summarize_vars, |
| 555 | ! |
add_total = input$add_total, |
| 556 | ! |
total_label = total_label, |
| 557 | ! |
var_labels = var_labels, |
| 558 | ! |
arm_var_labels = arm_var_labels, |
| 559 | ! |
na.rm = ifelse(input$useNA == "ifany", FALSE, TRUE), |
| 560 | ! |
na_level = na_level, |
| 561 | ! |
numeric_stats = input$numeric_stats, |
| 562 | ! |
denominator = input$denominator, |
| 563 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 564 | ! |
basic_table_args = basic_table_args |
| 565 |
) |
|
| 566 | ||
| 567 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 568 |
}) |
|
| 569 | ||
| 570 |
# Outputs to render. |
|
| 571 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 572 | ! |
teal.widgets::table_with_settings_srv(id = "table", table_r = table_r) |
| 573 | ||
| 574 |
# Render R code. |
|
| 575 | ! |
teal.widgets::verbatim_popup_srv( |
| 576 | ! |
id = "rcode", |
| 577 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 578 | ! |
title = label |
| 579 |
) |
|
| 580 | ||
| 581 |
### REPORTER |
|
| 582 | ! |
if (with_reporter) {
|
| 583 | ! |
card_fun <- function(comment, label) {
|
| 584 | ! |
card <- teal::report_card_template( |
| 585 | ! |
title = "Summary Table", |
| 586 | ! |
label = label, |
| 587 | ! |
with_filter = with_filter, |
| 588 | ! |
filter_panel_api = filter_panel_api |
| 589 |
) |
|
| 590 | ! |
card$append_text("Table", "header3")
|
| 591 | ! |
card$append_table(table_r()) |
| 592 | ! |
if (!comment == "") {
|
| 593 | ! |
card$append_text("Comment", "header3")
|
| 594 | ! |
card$append_text(comment) |
| 595 |
} |
|
| 596 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 597 | ! |
card |
| 598 |
} |
|
| 599 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 600 |
} |
|
| 601 |
### |
|
| 602 |
}) |
|
| 603 |
} |
| 1 |
#' Template for Generalized Estimating Equations (GEE) analysis module |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate an analysis table using Generalized Estimating Equations (GEE). |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param output_table (`character`)\cr type of output table (`"t_gee_cov", "t_gee_coef", "t_gee_lsmeans"`). |
|
| 7 |
#' @param data_model_fit (`character`)\cr dataset used to fit the model by `tern.gee::fit_gee()`. |
|
| 8 |
#' @param dataname_lsmeans (`character`)\cr dataset used for `alt_counts_df` argument of `rtables::build_table()`. |
|
| 9 |
#' @param split_covariates (`character`)\cr vector of names of variables to use as covariates in |
|
| 10 |
#' `tern.gee::vars_gee()`. |
|
| 11 |
#' @param cor_struct (`character`)\cr assumed correlation structure in `tern.gee::fit_gee`. |
|
| 12 |
#' |
|
| 13 |
#' @inherit template_arguments return |
|
| 14 |
#' |
|
| 15 |
#' @seealso [tm_a_gee()] |
|
| 16 |
#' |
|
| 17 |
#' @keywords internal |
|
| 18 |
template_a_gee <- function(output_table, |
|
| 19 |
data_model_fit = "ANL", |
|
| 20 |
dataname_lsmeans = "ANL_ADSL", |
|
| 21 |
input_arm_var = "ARM", |
|
| 22 |
ref_group = "A: Drug X", |
|
| 23 |
aval_var, |
|
| 24 |
id_var, |
|
| 25 |
arm_var, |
|
| 26 |
visit_var, |
|
| 27 |
split_covariates, |
|
| 28 |
cor_struct, |
|
| 29 |
conf_level = 0.95, |
|
| 30 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 31 | 4x |
y <- list() |
| 32 | 4x |
y$model <- list() |
| 33 | 4x |
y$table <- list() |
| 34 | ||
| 35 | 4x |
all_basic_table_args <- teal.widgets::resolve_basic_table_args(basic_table_args) |
| 36 | ||
| 37 | 4x |
model_list <- add_expr( |
| 38 | 4x |
list(), |
| 39 | 4x |
substitute( |
| 40 | 4x |
expr = {
|
| 41 | ! |
model_fit <- tern.gee::fit_gee( |
| 42 | ! |
vars = tern.gee::vars_gee( |
| 43 | ! |
response = as.vector(aval_var), |
| 44 | ! |
covariates = as.vector(split_covariates), |
| 45 | ! |
id = as.vector(id_var), |
| 46 | ! |
arm = as.vector(arm_var), |
| 47 | ! |
visit = as.vector(visit_var) |
| 48 |
), |
|
| 49 | ! |
data = data_model_fit, |
| 50 | ! |
regression = "logistic", |
| 51 | ! |
cor_struct = cor_struct |
| 52 |
) |
|
| 53 |
}, |
|
| 54 | 4x |
env = list( |
| 55 | 4x |
data_model_fit = as.name(data_model_fit), |
| 56 | 4x |
aval_var = aval_var, |
| 57 | 4x |
split_covariates = split_covariates, |
| 58 | 4x |
id_var = id_var, |
| 59 | 4x |
arm_var = arm_var, |
| 60 | 4x |
visit_var = visit_var, |
| 61 | 4x |
cor_struct = cor_struct |
| 62 |
) |
|
| 63 |
) |
|
| 64 |
) |
|
| 65 | ||
| 66 | 4x |
table_list <- |
| 67 | 4x |
add_expr( |
| 68 | 4x |
list(), |
| 69 | 4x |
if (output_table == "t_gee_cov") {
|
| 70 | 1x |
substitute( |
| 71 | 1x |
expr = {
|
| 72 | ! |
result_table <- tern.gee::as.rtable(model_fit, type = "cov") |
| 73 | ! |
subtitles(result_table) <- st |
| 74 | ! |
main_footer(result_table) <- mf |
| 75 |
}, |
|
| 76 | 1x |
env = list( |
| 77 | 1x |
st = basic_table_args$subtitles, |
| 78 | 1x |
mf = basic_table_args$main_footer |
| 79 |
) |
|
| 80 |
) |
|
| 81 | 4x |
} else if (output_table == "t_gee_coef") {
|
| 82 | 1x |
substitute( |
| 83 | 1x |
expr = {
|
| 84 | ! |
result_table <- tern.gee::as.rtable(data.frame(Coefficient = model_fit$coefficients)) |
| 85 | ! |
subtitles(result_table) <- st |
| 86 | ! |
main_footer(result_table) <- mf |
| 87 |
}, |
|
| 88 | 1x |
env = list( |
| 89 | 1x |
conf_level = conf_level, |
| 90 | 1x |
st = basic_table_args$subtitles, |
| 91 | 1x |
mf = basic_table_args$main_footer |
| 92 |
) |
|
| 93 |
) |
|
| 94 | 4x |
} else if (output_table == "t_gee_lsmeans") {
|
| 95 | 2x |
substitute( |
| 96 | 2x |
expr = {
|
| 97 | ! |
lsmeans_fit_model <- tern.gee::lsmeans(model_fit, conf_level) |
| 98 | ! |
result_table <- rtables::basic_table(show_colcounts = TRUE) %>% |
| 99 | ! |
rtables::split_cols_by(var = input_arm_var, ref_group = model_fit$ref_level) %>% |
| 100 | ! |
tern.gee::summarize_gee_logistic() %>% |
| 101 | ! |
rtables::build_table( |
| 102 | ! |
df = lsmeans_fit_model, |
| 103 | ! |
alt_counts_df = dataname_lsmeans |
| 104 |
) |
|
| 105 | ||
| 106 | ! |
subtitles(result_table) <- st |
| 107 | ! |
main_footer(result_table) <- mf |
| 108 | ! |
result_table |
| 109 |
}, |
|
| 110 | 2x |
env = list( |
| 111 | 2x |
dataname_lsmeans = as.name(dataname_lsmeans), |
| 112 | 2x |
conf_level = conf_level, |
| 113 | 2x |
input_arm_var = input_arm_var, |
| 114 | 2x |
st = basic_table_args$subtitles, |
| 115 | 2x |
mf = basic_table_args$main_footer |
| 116 |
) |
|
| 117 |
) |
|
| 118 |
} |
|
| 119 |
) |
|
| 120 |
# Note: l_html_concomitant_adcm is still not included since one column is available out of 9 |
|
| 121 | ||
| 122 | 4x |
y$model <- bracket_expr(model_list) |
| 123 | 4x |
y$table <- bracket_expr(table_list) |
| 124 | ||
| 125 | 4x |
y |
| 126 |
} |
|
| 127 | ||
| 128 |
#' teal Module: Generalized Estimating Equations (GEE) analysis |
|
| 129 |
#' |
|
| 130 |
#' This module produces an analysis table using Generalized Estimating Equations (GEE). |
|
| 131 |
#' |
|
| 132 |
#' @inheritParams module_arguments |
|
| 133 |
#' @inheritParams template_arguments |
|
| 134 |
#' @inheritParams template_a_gee |
|
| 135 |
#' |
|
| 136 |
#' @inherit module_arguments return seealso |
|
| 137 |
#' |
|
| 138 |
#' @examples |
|
| 139 |
#' library(dplyr) |
|
| 140 |
#' data <- teal_data() |
|
| 141 |
#' data <- within(data, {
|
|
| 142 |
#' ADSL <- tmc_ex_adsl |
|
| 143 |
#' ADQS <- tmc_ex_adqs %>% |
|
| 144 |
#' filter(ABLFL != "Y" & ABLFL2 != "Y") %>% |
|
| 145 |
#' mutate( |
|
| 146 |
#' AVISIT = as.factor(AVISIT), |
|
| 147 |
#' AVISITN = rank(AVISITN) %>% |
|
| 148 |
#' as.factor() %>% |
|
| 149 |
#' as.numeric() %>% |
|
| 150 |
#' as.factor(), |
|
| 151 |
#' AVALBIN = AVAL < 50 # Just as an example to get a binary endpoint. |
|
| 152 |
#' ) %>% |
|
| 153 |
#' droplevels() |
|
| 154 |
#' }) |
|
| 155 |
#' datanames <- c("ADSL", "ADQS")
|
|
| 156 |
#' datanames(data) <- datanames |
|
| 157 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 158 |
#' |
|
| 159 |
#' app <- init( |
|
| 160 |
#' data = data, |
|
| 161 |
#' modules = modules( |
|
| 162 |
#' tm_a_gee( |
|
| 163 |
#' label = "GEE", |
|
| 164 |
#' dataname = "ADQS", |
|
| 165 |
#' aval_var = choices_selected("AVALBIN", fixed = TRUE),
|
|
| 166 |
#' id_var = choices_selected(c("USUBJID", "SUBJID"), "USUBJID"),
|
|
| 167 |
#' arm_var = choices_selected(c("ARM", "ARMCD"), "ARM"),
|
|
| 168 |
#' visit_var = choices_selected(c("AVISIT", "AVISITN"), "AVISIT"),
|
|
| 169 |
#' paramcd = choices_selected( |
|
| 170 |
#' choices = value_choices(data[["ADQS"]], "PARAMCD", "PARAM"), |
|
| 171 |
#' selected = "FKSI-FWB" |
|
| 172 |
#' ), |
|
| 173 |
#' cov_var = choices_selected(c("BASE", "AGE", "SEX", "BASE:AVISIT"), NULL)
|
|
| 174 |
#' ) |
|
| 175 |
#' ) |
|
| 176 |
#' ) |
|
| 177 |
#' if (interactive()) {
|
|
| 178 |
#' shinyApp(app$ui, app$server) |
|
| 179 |
#' } |
|
| 180 |
#' |
|
| 181 |
#' @export |
|
| 182 |
tm_a_gee <- function(label, |
|
| 183 |
dataname, |
|
| 184 |
parentname = ifelse( |
|
| 185 |
inherits(arm_var, "data_extract_spec"), |
|
| 186 |
teal.transform::datanames_input(arm_var), |
|
| 187 |
"ADSL" |
|
| 188 |
), |
|
| 189 |
aval_var, |
|
| 190 |
id_var, |
|
| 191 |
arm_var, |
|
| 192 |
visit_var, |
|
| 193 |
cov_var, |
|
| 194 |
arm_ref_comp = NULL, |
|
| 195 |
paramcd, |
|
| 196 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 197 |
pre_output = NULL, |
|
| 198 |
post_output = NULL, |
|
| 199 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 200 | ! |
message("Initializing tm_a_gee (prototype)")
|
| 201 | ||
| 202 | ! |
cov_var <- teal.transform::add_no_selected_choices(cov_var, multiple = TRUE) |
| 203 | ||
| 204 | ! |
checkmate::assert_string(label) |
| 205 | ! |
checkmate::assert_string(dataname) |
| 206 | ! |
checkmate::assert_string(parentname) |
| 207 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 208 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 209 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 210 | ! |
checkmate::assert_class(visit_var, "choices_selected") |
| 211 | ! |
checkmate::assert_class(cov_var, "choices_selected") |
| 212 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 213 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 214 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 215 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 216 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 217 | ||
| 218 | ! |
args <- as.list(environment()) |
| 219 | ||
| 220 | ! |
data_extract_list <- list( |
| 221 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 222 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 223 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 224 | ! |
visit_var = cs_to_des_select(visit_var, dataname = dataname), |
| 225 | ! |
cov_var = cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE), |
| 226 | ! |
split_covariates = cs_to_des_select(split_choices(cov_var), dataname = dataname, multiple = TRUE), |
| 227 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname) |
| 228 |
) |
|
| 229 | ||
| 230 | ! |
teal::module( |
| 231 | ! |
label = label, |
| 232 | ! |
server = srv_gee, |
| 233 | ! |
ui = ui_gee, |
| 234 | ! |
ui_args = c(data_extract_list, args), |
| 235 | ! |
server_args = c( |
| 236 | ! |
data_extract_list, |
| 237 | ! |
list( |
| 238 | ! |
dataname = dataname, |
| 239 | ! |
parentname = parentname, |
| 240 | ! |
arm_ref_comp = arm_ref_comp, |
| 241 | ! |
label = label, |
| 242 | ! |
basic_table_args = basic_table_args |
| 243 |
) |
|
| 244 |
), |
|
| 245 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 246 |
) |
|
| 247 |
} |
|
| 248 | ||
| 249 |
ui_gee <- function(id, ...) {
|
|
| 250 | ! |
a <- list(...) # module args |
| 251 | ||
| 252 | ! |
ns <- NS(id) |
| 253 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 254 | ! |
a$arm_var, |
| 255 | ! |
a$paramcd, |
| 256 | ! |
a$id_var, |
| 257 | ! |
a$visit_var, |
| 258 | ! |
a$cov_var, |
| 259 | ! |
a$aval_var |
| 260 |
) |
|
| 261 | ||
| 262 | ! |
teal.widgets::standard_layout( |
| 263 | ! |
output = teal.widgets::white_small_well( |
| 264 | ! |
tags$h3(textOutput(ns("gee_title"))),
|
| 265 | ! |
teal.widgets::table_with_settings_ui(ns("table"))
|
| 266 |
), |
|
| 267 | ! |
encoding = tags$div( |
| 268 |
### Reporter |
|
| 269 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 270 |
### |
|
| 271 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 272 | ! |
teal.transform::datanames_input(a[c("arm_var", "paramcd", "id_var", "visit_var", "cov_var", "aval_var")]),
|
| 273 | ! |
teal.transform::data_extract_ui( |
| 274 | ! |
id = ns("aval_var"),
|
| 275 | ! |
label = "Analysis Variable", |
| 276 | ! |
data_extract_spec = a$aval_var, |
| 277 | ! |
is_single_dataset = is_single_dataset_value |
| 278 |
), |
|
| 279 | ! |
teal.transform::data_extract_ui( |
| 280 | ! |
id = ns("paramcd"),
|
| 281 | ! |
label = "Select Endpoint", |
| 282 | ! |
data_extract_spec = a$paramcd, |
| 283 | ! |
is_single_dataset = is_single_dataset_value |
| 284 |
), |
|
| 285 | ! |
teal.transform::data_extract_ui( |
| 286 | ! |
id = ns("visit_var"),
|
| 287 | ! |
label = "Visit Variable", |
| 288 | ! |
data_extract_spec = a$visit_var, |
| 289 | ! |
is_single_dataset = is_single_dataset_value |
| 290 |
), |
|
| 291 | ! |
teal.transform::data_extract_ui( |
| 292 | ! |
id = ns("cov_var"),
|
| 293 | ! |
label = "Covariates", |
| 294 | ! |
data_extract_spec = a$cov_var, |
| 295 | ! |
is_single_dataset = is_single_dataset_value |
| 296 |
), |
|
| 297 | ! |
shinyjs::hidden( |
| 298 | ! |
teal.transform::data_extract_ui( |
| 299 | ! |
id = ns("split_covariates"),
|
| 300 | ! |
label = "Split Covariates", |
| 301 | ! |
data_extract_spec = a$split_covariates, |
| 302 | ! |
is_single_dataset = is_single_dataset_value |
| 303 |
) |
|
| 304 |
), |
|
| 305 | ! |
teal.transform::data_extract_ui( |
| 306 | ! |
id = ns("arm_var"),
|
| 307 | ! |
label = "Select Treatment Variable", |
| 308 | ! |
data_extract_spec = a$arm_var, |
| 309 | ! |
is_single_dataset = is_single_dataset_value |
| 310 |
), |
|
| 311 | ! |
shinyjs::hidden( |
| 312 | ! |
uiOutput(ns("arms_buckets")),
|
| 313 | ! |
helpText( |
| 314 | ! |
id = ns("help_text"), "Multiple reference groups are automatically combined into a single group."
|
| 315 |
), |
|
| 316 | ! |
checkboxInput( |
| 317 | ! |
ns("combine_comp_arms"),
|
| 318 | ! |
"Combine all comparison groups?", |
| 319 | ! |
value = FALSE |
| 320 |
) |
|
| 321 |
), |
|
| 322 | ! |
teal.transform::data_extract_ui( |
| 323 | ! |
id = ns("id_var"),
|
| 324 | ! |
label = "Subject Identifier", |
| 325 | ! |
data_extract_spec = a$id_var, |
| 326 | ! |
is_single_dataset = is_single_dataset_value |
| 327 |
), |
|
| 328 | ! |
selectInput( |
| 329 | ! |
ns("cor_struct"),
|
| 330 | ! |
"Correlation Structure", |
| 331 | ! |
choices = c( |
| 332 | ! |
"unstructured", |
| 333 | ! |
"toeplitz", # needs the fix of https://github.com/insightsengineering/tern.gee/issues/3 |
| 334 | ! |
"auto-regressive", |
| 335 | ! |
"compound symmetry" |
| 336 |
), |
|
| 337 | ! |
selected = "unstructured", |
| 338 | ! |
multiple = FALSE |
| 339 |
), |
|
| 340 | ! |
teal.widgets::optionalSelectInput( |
| 341 | ! |
ns("conf_level"),
|
| 342 | ! |
"Confidence Level", |
| 343 | ! |
a$conf_level$choices, |
| 344 | ! |
a$conf_level$selected, |
| 345 | ! |
multiple = FALSE, |
| 346 | ! |
fixed = a$conf_level$fixed |
| 347 |
), |
|
| 348 | ! |
radioButtons( |
| 349 | ! |
ns("output_table"),
|
| 350 | ! |
"Output Type", |
| 351 | ! |
choices = c( |
| 352 | ! |
"LS means" = "t_gee_lsmeans", |
| 353 | ! |
"Covariance" = "t_gee_cov", |
| 354 | ! |
"Coefficients" = "t_gee_coef" |
| 355 |
), |
|
| 356 | ! |
selected = "t_gee_lsmeans" |
| 357 |
) |
|
| 358 |
), |
|
| 359 | ! |
forms = tagList( |
| 360 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 361 |
), |
|
| 362 | ! |
pre_output = a$pre_output, |
| 363 | ! |
post_output = a$post_output |
| 364 |
) |
|
| 365 |
} |
|
| 366 | ||
| 367 |
srv_gee <- function(id, |
|
| 368 |
data, |
|
| 369 |
filter_panel_api, |
|
| 370 |
reporter, |
|
| 371 |
dataname, |
|
| 372 |
parentname, |
|
| 373 |
arm_var, |
|
| 374 |
paramcd, |
|
| 375 |
id_var, |
|
| 376 |
visit_var, |
|
| 377 |
cov_var, |
|
| 378 |
split_covariates, |
|
| 379 |
aval_var, |
|
| 380 |
arm_ref_comp, |
|
| 381 |
label, |
|
| 382 |
plot_height, |
|
| 383 |
plot_width, |
|
| 384 |
basic_table_args) {
|
|
| 385 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 386 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 387 | ! |
checkmate::assert_class(data, "reactive") |
| 388 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 389 | ||
| 390 | ! |
moduleServer(id, function(input, output, session) {
|
| 391 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 392 |
## split_covariates ---- |
|
| 393 | ! |
observeEvent(input[[extract_input("cov_var", dataname)]],
|
| 394 | ! |
ignoreNULL = FALSE, |
| 395 |
{
|
|
| 396 |
# update covariates as actual variables |
|
| 397 | ! |
split_interactions_values <- split_interactions( |
| 398 | ! |
input[[extract_input("cov_var", dataname)]]
|
| 399 |
) |
|
| 400 | ! |
arm_var_value <- input[[extract_input("arm_var", parentname)]]
|
| 401 | ! |
arm_in_cov <- length(intersect(split_interactions_values, arm_var_value)) >= 1L |
| 402 | ! |
if (arm_in_cov) {
|
| 403 | ! |
split_covariates_selected <- setdiff(split_interactions_values, arm_var_value) |
| 404 |
} else {
|
|
| 405 | ! |
split_covariates_selected <- split_interactions_values |
| 406 |
} |
|
| 407 | ! |
teal.widgets::updateOptionalSelectInput( |
| 408 | ! |
session, |
| 409 | ! |
inputId = extract_input("split_covariates", dataname),
|
| 410 | ! |
selected = split_covariates_selected |
| 411 |
) |
|
| 412 |
} |
|
| 413 |
) |
|
| 414 | ||
| 415 |
## arm_ref_comp_observer ---- |
|
| 416 | ! |
arm_ref_comp_observer( |
| 417 | ! |
session, |
| 418 | ! |
input, |
| 419 | ! |
output, |
| 420 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 421 | ! |
data = reactive(data()[[parentname]]), |
| 422 | ! |
arm_ref_comp = arm_ref_comp, |
| 423 | ! |
module = "tm_a_gee" |
| 424 |
) |
|
| 425 | ||
| 426 |
## data_merge_modules ---- |
|
| 427 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 428 | ! |
data_extract = list( |
| 429 | ! |
arm_var = arm_var, |
| 430 | ! |
paramcd = paramcd, |
| 431 | ! |
id_var = id_var, |
| 432 | ! |
visit_var = visit_var, |
| 433 | ! |
split_covariates = split_covariates, |
| 434 | ! |
aval_var = aval_var |
| 435 |
), |
|
| 436 | ! |
datasets = data, |
| 437 | ! |
select_validation_rule = list( |
| 438 | ! |
aval_var = shinyvalidate::sv_required("An analysis variable is required"),
|
| 439 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required"),
|
| 440 | ! |
id_var = shinyvalidate::sv_required("A Subject identifier is required"),
|
| 441 | ! |
visit_var = shinyvalidate::sv_required("A visit variable is required")
|
| 442 |
), |
|
| 443 | ! |
filter_validation_rule = list( |
| 444 | ! |
paramcd = shinyvalidate::sv_required("An endpoint is required")
|
| 445 |
) |
|
| 446 |
) |
|
| 447 | ||
| 448 | ! |
iv_r <- reactive({
|
| 449 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 450 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level"))
|
| 451 | ! |
iv$add_rule( |
| 452 | ! |
"conf_level", |
| 453 | ! |
shinyvalidate::sv_between( |
| 454 | ! |
0, 1, |
| 455 | ! |
inclusive = c(FALSE, FALSE), |
| 456 | ! |
message_fmt = "Confidence level must be between 0 and 1" |
| 457 |
) |
|
| 458 |
) |
|
| 459 | ! |
iv$add_rule("cor_struct", shinyvalidate::sv_required("Please choose a correlation structure"))
|
| 460 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 461 |
}) |
|
| 462 | ||
| 463 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 464 | ! |
datasets = data, |
| 465 | ! |
selector_list = selector_list, |
| 466 | ! |
merge_function = "dplyr::inner_join" |
| 467 |
) |
|
| 468 | ||
| 469 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 470 | ! |
datasets = data, |
| 471 | ! |
data_extract = list(arm_var = arm_var), |
| 472 | ! |
anl_name = "ANL_ADSL" |
| 473 |
) |
|
| 474 | ||
| 475 | ! |
anl_q <- reactive({
|
| 476 | ! |
data() %>% |
| 477 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 478 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 479 |
}) |
|
| 480 | ||
| 481 | ! |
merged <- list( |
| 482 | ! |
anl_input_r = anl_inputs, |
| 483 | ! |
adsl_input_r = adsl_inputs, |
| 484 | ! |
anl_q = anl_q |
| 485 |
) |
|
| 486 | ||
| 487 |
# Initially hide the output title because there is no output yet. |
|
| 488 | ! |
shinyjs::show("gee_title")
|
| 489 | ||
| 490 | ! |
validate_checks <- reactive({
|
| 491 | ! |
teal::validate_inputs(iv_r()) |
| 492 | ||
| 493 |
# To do in production: add validations. |
|
| 494 | ! |
NULL |
| 495 |
}) |
|
| 496 | ||
| 497 |
## table_r ---- |
|
| 498 | ! |
table_q <- reactive({
|
| 499 | ! |
validate_checks() |
| 500 | ! |
output_table <- input$output_table |
| 501 | ! |
conf_level <- as.numeric(input$conf_level) |
| 502 | ! |
col_source <- merged$anl_input_r()$columns_source |
| 503 | ! |
filter_info <- merged$anl_input_r()$filter_info |
| 504 | ||
| 505 | ! |
req(output_table) |
| 506 | ||
| 507 | ! |
basic_table_args$subtitles <- paste0( |
| 508 | ! |
"Analysis Variable: ", col_source$aval_var, |
| 509 | ! |
", Endpoint: ", filter_info$paramcd[[1]]$selected[[1]], |
| 510 | ! |
ifelse(length(col_source$split_covariates) == 0, "", |
| 511 | ! |
paste(", Covariates:", paste(col_source$split_covariates, collapse = ", "))
|
| 512 |
) |
|
| 513 |
) |
|
| 514 | ! |
basic_table_args$main_footer <- c(paste("Correlation Structure:", input$cor_struct))
|
| 515 | ||
| 516 | ! |
my_calls <- template_a_gee( |
| 517 | ! |
output_table = output_table, |
| 518 | ! |
data_model_fit = "ANL", |
| 519 | ! |
dataname_lsmeans = "ANL_ADSL", |
| 520 | ! |
input_arm_var = as.vector(col_source$arm_var), |
| 521 | ! |
conf_level = conf_level, |
| 522 | ! |
aval_var = col_source$aval_var, |
| 523 | ! |
split_covariates = col_source$split_covariates, |
| 524 | ! |
id_var = col_source$id_var, |
| 525 | ! |
arm_var = col_source$arm_var, |
| 526 | ! |
visit_var = col_source$visit_var, |
| 527 | ! |
cor_struct = input$cor_struct, |
| 528 | ! |
basic_table_args = basic_table_args |
| 529 |
) |
|
| 530 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 531 |
}) |
|
| 532 | ||
| 533 | ! |
output$gee_title <- renderText({
|
| 534 |
# Input on output type. |
|
| 535 | ! |
output_table <- input$output_table |
| 536 | ||
| 537 | ! |
output_title <- switch(output_table, |
| 538 | ! |
"t_gee_cov" = "Residual Covariance Matrix Estimate", |
| 539 | ! |
"t_gee_coef" = "Model Coefficients", |
| 540 | ! |
"t_gee_lsmeans" = "LS Means Estimates" |
| 541 |
) |
|
| 542 | ! |
output_title |
| 543 |
}) |
|
| 544 | ||
| 545 | ! |
table_r <- reactive({
|
| 546 | ! |
table_q()[["result_table"]] |
| 547 |
}) |
|
| 548 | ||
| 549 | ! |
teal.widgets::table_with_settings_srv( |
| 550 | ! |
id = "table", |
| 551 | ! |
table_r = table_r |
| 552 |
) |
|
| 553 | ||
| 554 |
# Render R code |
|
| 555 | ! |
teal.widgets::verbatim_popup_srv( |
| 556 | ! |
id = "rcode", |
| 557 | ! |
verbatim_content = reactive(teal.code::get_code(table_q())), |
| 558 | ! |
title = label |
| 559 |
) |
|
| 560 | ||
| 561 |
### REPORTER |
|
| 562 | ! |
if (with_reporter) {
|
| 563 | ! |
card_fun <- function(comment, label) {
|
| 564 | ! |
card <- teal::report_card_template( |
| 565 | ! |
title = "Generalized Estimating Equations (GEE) Analysis Table", |
| 566 | ! |
label = label, |
| 567 | ! |
with_filter = with_filter, |
| 568 | ! |
filter_panel_api = filter_panel_api |
| 569 |
) |
|
| 570 | ! |
table_type <- switch(input$output_table, |
| 571 | ! |
"t_gee_cov" = "Residual Covariance Matrix Estimate", |
| 572 | ! |
"t_gee_coef" = "Model Coefficients", |
| 573 | ! |
"t_gee_lsmeans" = "LS Means Estimates" |
| 574 |
) |
|
| 575 | ! |
card$append_text(paste(table_type, "Table"), "header3") |
| 576 | ! |
card$append_table(table_r()) |
| 577 | ! |
if (!comment == "") {
|
| 578 | ! |
card$append_text("Comment", "header3")
|
| 579 | ! |
card$append_text(comment) |
| 580 |
} |
|
| 581 | ! |
card$append_src(teal.code::get_code(table_q())) |
| 582 | ! |
card |
| 583 |
} |
|
| 584 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 585 |
} |
|
| 586 |
}) |
|
| 587 |
} |
| 1 |
#' Control Function for Time-To-Event teal Module |
|
| 2 |
#' |
|
| 3 |
#' Controls the arguments for Cox regression and survival analysis results. |
|
| 4 |
#' |
|
| 5 |
#' @param coxph (`list`)\cr control parameters for Cox-PH model. See [tern::control_coxph()] for details. |
|
| 6 |
#' @param surv_time (`list`)\cr control parameters for `survfit` model. See [tern::control_surv_time()] for details. |
|
| 7 |
#' @param surv_timepoint (`list`)\cr control parameters for `survfit` model at time point. See |
|
| 8 |
#' [tern::control_surv_timepoint()] for details. |
|
| 9 |
#' |
|
| 10 |
#' @seealso [template_tte()], [tm_t_tte()] |
|
| 11 |
#' |
|
| 12 |
#' @keywords internal |
|
| 13 |
control_tte <- function( |
|
| 14 |
surv_time = list( |
|
| 15 |
conf_level = 0.95, |
|
| 16 |
conf_type = "plain", |
|
| 17 |
quantiles = c(0.25, 0.75) |
|
| 18 |
), |
|
| 19 |
coxph = list( |
|
| 20 |
pval_method = "log-rank", |
|
| 21 |
ties = "efron", |
|
| 22 |
conf_level = 0.95 |
|
| 23 |
), |
|
| 24 |
surv_timepoint = control_surv_timepoint( |
|
| 25 |
conf_level = 0.95, |
|
| 26 |
conf_type = c("plain", "none", "log", "log-log")
|
|
| 27 |
)) {
|
|
| 28 | 4x |
list( |
| 29 | 4x |
surv_time = do.call("control_surv_time", surv_time),
|
| 30 | 4x |
coxph = do.call("control_coxph", coxph),
|
| 31 | 4x |
surv_timepoint = do.call("control_surv_timepoint", surv_timepoint)
|
| 32 |
) |
|
| 33 |
} |
|
| 34 | ||
| 35 |
#' Template: Time-To-Event |
|
| 36 |
#' |
|
| 37 |
#' Creates a valid expression to generate a time-to-event analysis. |
|
| 38 |
#' |
|
| 39 |
#' @inheritParams template_arguments |
|
| 40 |
#' @param control (`list`)\cr list of settings for the analysis. See [control_tte()] for details. |
|
| 41 |
#' @param event_desc_var (`character`)\cr name of the variable with events description. |
|
| 42 |
#' @param paramcd (`character`)\cr endpoint parameter value to use in the table title. |
|
| 43 |
#' |
|
| 44 |
#' @inherit template_arguments return |
|
| 45 |
#' |
|
| 46 |
#' @seealso [control_tte()], [tm_t_tte()] |
|
| 47 |
#' |
|
| 48 |
#' @keywords internal |
|
| 49 |
template_tte <- function(dataname = "ANL", |
|
| 50 |
parentname = "ADSL", |
|
| 51 |
arm_var = "ARM", |
|
| 52 |
paramcd, |
|
| 53 |
ref_arm = NULL, |
|
| 54 |
comp_arm = NULL, |
|
| 55 |
compare_arm = FALSE, |
|
| 56 |
combine_comp_arms = FALSE, |
|
| 57 |
aval_var = "AVAL", |
|
| 58 |
cnsr_var = "CNSR", |
|
| 59 |
strata_var = NULL, |
|
| 60 |
time_points = NULL, |
|
| 61 |
time_unit_var = "AVALU", |
|
| 62 |
event_desc_var = "EVNTDESC", |
|
| 63 |
control = control_tte(), |
|
| 64 |
add_total = FALSE, |
|
| 65 |
total_label = default_total_label(), |
|
| 66 |
na_level = default_na_str(), |
|
| 67 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 68 | 4x |
checkmate::assert_string(dataname) |
| 69 | 4x |
checkmate::assert_string(parentname) |
| 70 | 4x |
checkmate::assert_string(arm_var) |
| 71 | 4x |
checkmate::assert_string(aval_var) |
| 72 | 4x |
checkmate::assert_string(cnsr_var) |
| 73 | 4x |
checkmate::assert_string(time_unit_var) |
| 74 | 4x |
checkmate::assert_string(event_desc_var) |
| 75 | 4x |
checkmate::assert_flag(compare_arm) |
| 76 | 4x |
checkmate::assert_flag(combine_comp_arms) |
| 77 | 4x |
checkmate::assert_string(total_label) |
| 78 | 4x |
checkmate::assert_string(na_level) |
| 79 | ||
| 80 | 4x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 81 | 4x |
y <- list() |
| 82 | ||
| 83 | 4x |
data_list <- list() |
| 84 | 4x |
data_list <- add_expr( |
| 85 | 4x |
data_list, |
| 86 | 4x |
prepare_arm( |
| 87 | 4x |
dataname = dataname, |
| 88 | 4x |
arm_var = arm_var, |
| 89 | 4x |
ref_arm = ref_arm, |
| 90 | 4x |
comp_arm = comp_arm, |
| 91 | 4x |
compare_arm = compare_arm, |
| 92 | 4x |
ref_arm_val = ref_arm_val |
| 93 |
) |
|
| 94 |
) |
|
| 95 | ||
| 96 | 4x |
data_list <- add_expr( |
| 97 | 4x |
data_list, |
| 98 | 4x |
substitute( |
| 99 | 4x |
expr = dplyr::mutate( |
| 100 | 4x |
is_event = cnsr_var == 0, |
| 101 | 4x |
is_not_event = cnsr_var == 1, |
| 102 | 4x |
EVNT1 = factor( |
| 103 | 4x |
dplyr::case_when( |
| 104 | 4x |
is_event == TRUE ~ "Patients with event (%)", |
| 105 | 4x |
is_event == FALSE ~ "Patients without event (%)" |
| 106 |
), |
|
| 107 | 4x |
levels = c("Patients with event (%)", "Patients without event (%)")
|
| 108 |
), |
|
| 109 | 4x |
EVNTDESC = factor(event_desc_var) |
| 110 |
), |
|
| 111 | 4x |
env = list( |
| 112 | 4x |
cnsr_var = as.name(cnsr_var), |
| 113 | 4x |
event_desc_var = as.name(event_desc_var) |
| 114 |
) |
|
| 115 |
) |
|
| 116 |
) |
|
| 117 | ||
| 118 | 4x |
data_list <- add_expr( |
| 119 | 4x |
data_list, |
| 120 | 4x |
substitute( |
| 121 | 4x |
expr = df_explicit_na(na_level = na_str), |
| 122 | 4x |
env = list(na_str = na_level) |
| 123 |
) |
|
| 124 |
) |
|
| 125 | ||
| 126 | 4x |
y$data <- substitute( |
| 127 | 4x |
expr = {
|
| 128 | ! |
anl <- data_pipe |
| 129 | ! |
parentname <- arm_preparation %>% df_explicit_na(na_level = na_str) |
| 130 |
}, |
|
| 131 | 4x |
env = list( |
| 132 | 4x |
data_pipe = pipe_expr(data_list), |
| 133 | 4x |
parentname = as.name(parentname), |
| 134 | 4x |
arm_preparation = prepare_arm( |
| 135 | 4x |
dataname = parentname, |
| 136 | 4x |
arm_var = arm_var, |
| 137 | 4x |
ref_arm = ref_arm, |
| 138 | 4x |
comp_arm = comp_arm, |
| 139 | 4x |
compare_arm = compare_arm, |
| 140 | 4x |
ref_arm_val = ref_arm_val |
| 141 |
), |
|
| 142 | 4x |
na_str = na_level |
| 143 |
) |
|
| 144 |
) |
|
| 145 | ||
| 146 | 4x |
if (compare_arm && combine_comp_arms) {
|
| 147 | 1x |
y$combine_comp_arms <- substitute( |
| 148 | 1x |
expr = groups <- combine_groups(fct = df[[group]], ref = ref_arm_val), |
| 149 | 1x |
env = list( |
| 150 | 1x |
df = as.name(parentname), |
| 151 | 1x |
group = arm_var, |
| 152 | 1x |
ref_arm_val = ref_arm_val |
| 153 |
) |
|
| 154 |
) |
|
| 155 |
} |
|
| 156 | 4x |
layout_list <- list() |
| 157 | ||
| 158 | 4x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 159 | 4x |
teal.widgets::resolve_basic_table_args( |
| 160 | 4x |
user_table = basic_table_args, |
| 161 | 4x |
module_table = teal.widgets::basic_table_args( |
| 162 | 4x |
show_colcounts = TRUE, |
| 163 | 4x |
title = paste("Time-To-Event Table for", paramcd),
|
| 164 | 4x |
main_footer = if (compare_arm) {
|
| 165 | 2x |
c( |
| 166 | 2x |
paste("p-value method for Coxph (Hazard Ratio):", control$coxph$pval_method),
|
| 167 | 2x |
paste("Ties for Coxph (Hazard Ratio):", control$coxph$ties),
|
| 168 | 2x |
paste("Confidence Level Type for Survfit:", control$surv_time$conf_type)
|
| 169 |
) |
|
| 170 |
} else {
|
|
| 171 | 2x |
paste("Confidence Level Type for Survfit:", control$surv_time$conf_type)
|
| 172 |
} |
|
| 173 |
) |
|
| 174 |
) |
|
| 175 |
) |
|
| 176 | ||
| 177 | 4x |
layout_list <- add_expr( |
| 178 | 4x |
layout_list, |
| 179 | 4x |
parsed_basic_table_args |
| 180 |
) |
|
| 181 | ||
| 182 | 4x |
if (!compare_arm && !combine_comp_arms && add_total) {
|
| 183 | ! |
layout_list <- add_expr( |
| 184 | ! |
layout_list, |
| 185 | ! |
substitute( |
| 186 | ! |
rtables::split_cols_by( |
| 187 | ! |
var = arm_var, |
| 188 | ! |
split_fun = add_overall_level(total_label, first = FALSE) |
| 189 |
), |
|
| 190 | ! |
env = list( |
| 191 | ! |
arm_var = arm_var, |
| 192 | ! |
total_label = total_label |
| 193 |
) |
|
| 194 |
) |
|
| 195 |
) |
|
| 196 |
} else {
|
|
| 197 | 4x |
layout_list <- add_expr( |
| 198 | 4x |
layout_list, |
| 199 | 4x |
split_col_expr( |
| 200 | 4x |
compare = compare_arm, |
| 201 | 4x |
combine = combine_comp_arms, |
| 202 | 4x |
arm_var = arm_var, |
| 203 | 4x |
ref = ref_arm_val |
| 204 |
) |
|
| 205 |
) |
|
| 206 |
} |
|
| 207 | ||
| 208 | 4x |
layout_list <- add_expr( |
| 209 | 4x |
layout_list, |
| 210 | 4x |
substitute( |
| 211 | 4x |
expr = analyze_vars( |
| 212 | 4x |
"is_event", |
| 213 | 4x |
.stats = "count_fraction", |
| 214 | 4x |
.labels = c(count_fraction = "Patients with event (%)"), |
| 215 | 4x |
na_str = na_str |
| 216 |
) %>% |
|
| 217 | 4x |
rtables::split_rows_by( |
| 218 | 4x |
"EVNT1", |
| 219 | 4x |
split_label = "Earliest contributing event", |
| 220 | 4x |
split_fun = keep_split_levels("Patients with event (%)"),
|
| 221 | 4x |
label_pos = "visible", |
| 222 | 4x |
child_labels = "hidden", |
| 223 | 4x |
indent_mod = 1L, |
| 224 |
) %>% |
|
| 225 | 4x |
rtables::split_rows_by(event_desc_var, split_fun = drop_split_levels) %>% |
| 226 | 4x |
rtables::summarize_row_groups(format = "xx", na_str = na_str) %>% |
| 227 | 4x |
analyze_vars( |
| 228 | 4x |
"is_not_event", |
| 229 | 4x |
.stats = "count_fraction", |
| 230 | 4x |
.labels = c(count_fraction = "Patients without event (%)"), |
| 231 | 4x |
nested = FALSE, |
| 232 | 4x |
show_labels = "hidden", |
| 233 | 4x |
na_str = na_str |
| 234 |
), |
|
| 235 | 4x |
env = list( |
| 236 | 4x |
event_desc_var = event_desc_var, |
| 237 | 4x |
na_str = na_level |
| 238 |
) |
|
| 239 |
) |
|
| 240 |
) |
|
| 241 | ||
| 242 | 4x |
layout_list <- add_expr( |
| 243 | 4x |
layout_list, |
| 244 | 4x |
substitute( |
| 245 | 4x |
expr = surv_time( |
| 246 | 4x |
vars = aval_var, |
| 247 | 4x |
var_labels = paste0("Time to Event (", as.character(anl$time_unit_var[1]), ")"),
|
| 248 | 4x |
is_event = "is_event", |
| 249 | 4x |
control = list( |
| 250 | 4x |
conf_level = conf_level, |
| 251 | 4x |
conf_type = conf_type, |
| 252 | 4x |
quantiles = quantiles |
| 253 |
), |
|
| 254 | 4x |
na_str = na_str, |
| 255 | 4x |
table_names = "time_to_event" |
| 256 |
), |
|
| 257 | 4x |
env = c( |
| 258 | 4x |
aval_var = aval_var, |
| 259 | 4x |
control$surv_time, |
| 260 | 4x |
time_unit_var = as.name(time_unit_var), |
| 261 | 4x |
na_str = na_level |
| 262 |
) |
|
| 263 |
) |
|
| 264 |
) |
|
| 265 | ||
| 266 | 4x |
if (compare_arm) {
|
| 267 | 2x |
layout_list <- add_expr( |
| 268 | 2x |
layout_list, |
| 269 | 2x |
substitute( |
| 270 | 2x |
expr = coxph_pairwise( |
| 271 | 2x |
vars = aval_var, |
| 272 | 2x |
is_event = "is_event", |
| 273 | 2x |
var_labels = c("Unstratified Analysis"),
|
| 274 | 2x |
control = list( |
| 275 | 2x |
pval_method = pval_method, |
| 276 | 2x |
ties = ties, |
| 277 | 2x |
conf_level = conf_level |
| 278 |
), |
|
| 279 | 2x |
na_str = na_str, |
| 280 | 2x |
table_names = "unstratified" |
| 281 |
), |
|
| 282 | 2x |
env = c( |
| 283 | 2x |
aval_var = aval_var, |
| 284 | 2x |
control$coxph, |
| 285 | 2x |
na_str = na_level |
| 286 |
) |
|
| 287 |
) |
|
| 288 |
) |
|
| 289 |
} |
|
| 290 | ||
| 291 | 4x |
if (compare_arm && !is.null(strata_var)) {
|
| 292 | ! |
layout_list <- add_expr( |
| 293 | ! |
layout_list, |
| 294 | ! |
substitute( |
| 295 | ! |
expr = coxph_pairwise( |
| 296 | ! |
vars = aval_var, |
| 297 | ! |
is_event = "is_event", |
| 298 | ! |
var_labels = paste0("Stratified By: ", paste(strata_var, collapse = ", ")),
|
| 299 | ! |
strata = strata_var, |
| 300 | ! |
control = control_coxph( |
| 301 | ! |
pval_method = pval_method, |
| 302 | ! |
ties = ties, |
| 303 | ! |
conf_level = conf_level |
| 304 |
), |
|
| 305 | ! |
na_str = na_str, |
| 306 | ! |
table_names = "stratified" |
| 307 |
), |
|
| 308 | ! |
env = list( |
| 309 | ! |
aval_var = aval_var, |
| 310 | ! |
strata_var = strata_var, |
| 311 | ! |
pval_method = control$coxph$pval_method, |
| 312 | ! |
ties = control$coxph$ties, |
| 313 | ! |
conf_level = control$coxph$conf_level, |
| 314 | ! |
na_str = na_level |
| 315 |
) |
|
| 316 |
) |
|
| 317 |
) |
|
| 318 |
} |
|
| 319 | ||
| 320 | 4x |
if (!is.null(time_points)) {
|
| 321 | 4x |
method <- ifelse(compare_arm, "both", "surv") |
| 322 | 4x |
indents <- if (compare_arm) {
|
| 323 | 2x |
c( |
| 324 | 2x |
"pt_at_risk" = 0L, "event_free_rate" = 0L, "rate_ci" = 0L, |
| 325 | 2x |
"rate_diff" = 1L, "rate_diff_ci" = 1L, "ztest_pval" = 1L |
| 326 |
) |
|
| 327 |
} else {
|
|
| 328 | 2x |
NULL |
| 329 |
} |
|
| 330 | 4x |
layout_list <- add_expr( |
| 331 | 4x |
layout_list, |
| 332 | 4x |
substitute( |
| 333 | 4x |
expr = surv_timepoint( |
| 334 | 4x |
vars = aval_var, |
| 335 | 4x |
var_labels = as.character(anl$time_unit_var[1]), |
| 336 | 4x |
is_event = "is_event", |
| 337 | 4x |
time_point = time_points, |
| 338 | 4x |
method = method, |
| 339 | 4x |
control = control_surv_timepoint( |
| 340 | 4x |
conf_level = conf_level, |
| 341 | 4x |
conf_type = conf_type |
| 342 |
), |
|
| 343 | 4x |
.indent_mods = indents, |
| 344 | 4x |
na_str = na_str |
| 345 |
), |
|
| 346 | 4x |
env = list( |
| 347 | 4x |
aval_var = aval_var, |
| 348 | 4x |
time_points = time_points, |
| 349 | 4x |
method = method, |
| 350 | 4x |
indents = indents, |
| 351 | 4x |
time_unit_var = as.name(time_unit_var), |
| 352 | 4x |
conf_level = control$surv_timepoint$conf_level, |
| 353 | 4x |
conf_type = control$surv_timepoint$conf_type, |
| 354 | 4x |
na_str = na_level |
| 355 |
) |
|
| 356 |
) |
|
| 357 |
) |
|
| 358 |
} |
|
| 359 | ||
| 360 | 4x |
y$layout <- substitute( |
| 361 | 4x |
expr = lyt <- layout_pipe, |
| 362 | 4x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 363 |
) |
|
| 364 | ||
| 365 | 4x |
y$table <- substitute( |
| 366 | 4x |
expr = {
|
| 367 | ! |
table <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parentname) |
| 368 | ! |
table |
| 369 |
}, |
|
| 370 | 4x |
env = list(parentname = as.name(parentname)) |
| 371 |
) |
|
| 372 | ||
| 373 | 4x |
y |
| 374 |
} |
|
| 375 | ||
| 376 |
#' teal Module: Time-To-Event Table |
|
| 377 |
#' |
|
| 378 |
#' This module produces a time-to-event analysis summary table, consistent with the TLG Catalog |
|
| 379 |
#' template for `TTET01` available [here]( |
|
| 380 |
#' https://insightsengineering.github.io/tlg-catalog/stable/tables/efficacy/ttet01.html). |
|
| 381 |
#' |
|
| 382 |
#' @inheritParams module_arguments |
|
| 383 |
#' @inheritParams template_tte |
|
| 384 |
#' @param conf_level_coxph ([teal.transform::choices_selected()])\cr object with all available choices and |
|
| 385 |
#' pre-selected option for confidence level, each within range of (0, 1). |
|
| 386 |
#' @param conf_level_survfit ([teal.transform::choices_selected()])\cr object with all available choices and |
|
| 387 |
#' pre-selected option for confidence level, each within range of (0, 1). |
|
| 388 |
#' @param event_desc_var (`character` or [data_extract_spec()])\cr variable name with the event description |
|
| 389 |
#' information, optional. |
|
| 390 |
#' |
|
| 391 |
#' @details |
|
| 392 |
#' * The core functionality of this module is based on [coxph_pairwise()], [surv_timepoint()], and [surv_time()] from |
|
| 393 |
#' the `tern` package. |
|
| 394 |
#' * The arm and stratification variables are taken from the `parentname` data. |
|
| 395 |
#' * The following variables are used in the module: |
|
| 396 |
#' |
|
| 397 |
#' * `AVAL`: time to event |
|
| 398 |
#' * `CNSR`: 1 if record in `AVAL` is censored, 0 otherwise |
|
| 399 |
#' * `PARAMCD`: variable used to filter for endpoint (e.g. OS). After |
|
| 400 |
#' filtering for `PARAMCD` one observation per patient is expected |
|
| 401 |
#' |
|
| 402 |
#' @inherit module_arguments return seealso |
|
| 403 |
#' |
|
| 404 |
#' @examples |
|
| 405 |
#' ADSL <- tmc_ex_adsl |
|
| 406 |
#' ADTTE <- tmc_ex_adtte |
|
| 407 |
#' |
|
| 408 |
#' arm_ref_comp <- list( |
|
| 409 |
#' ACTARMCD = list( |
|
| 410 |
#' ref = "ARM B", |
|
| 411 |
#' comp = c("ARM A", "ARM C")
|
|
| 412 |
#' ), |
|
| 413 |
#' ARM = list( |
|
| 414 |
#' ref = "B: Placebo", |
|
| 415 |
#' comp = c("A: Drug X", "C: Combination")
|
|
| 416 |
#' ) |
|
| 417 |
#' ) |
|
| 418 |
#' |
|
| 419 |
#' app <- init( |
|
| 420 |
#' data = cdisc_data( |
|
| 421 |
#' ADSL = ADSL, |
|
| 422 |
#' ADTTE = ADTTE, |
|
| 423 |
#' code = " |
|
| 424 |
#' ADSL <- tmc_ex_adsl |
|
| 425 |
#' ADTTE <- tmc_ex_adtte |
|
| 426 |
#' " |
|
| 427 |
#' ), |
|
| 428 |
#' modules = modules( |
|
| 429 |
#' tm_t_tte( |
|
| 430 |
#' label = "Time To Event Table", |
|
| 431 |
#' dataname = "ADTTE", |
|
| 432 |
#' arm_var = choices_selected( |
|
| 433 |
#' variable_choices(ADSL, c("ARM", "ARMCD", "ACTARMCD")),
|
|
| 434 |
#' "ARM" |
|
| 435 |
#' ), |
|
| 436 |
#' arm_ref_comp = arm_ref_comp, |
|
| 437 |
#' paramcd = choices_selected( |
|
| 438 |
#' value_choices(ADTTE, "PARAMCD", "PARAM"), |
|
| 439 |
#' "OS" |
|
| 440 |
#' ), |
|
| 441 |
#' strata_var = choices_selected( |
|
| 442 |
#' variable_choices(ADSL, c("SEX", "BMRKR2")),
|
|
| 443 |
#' "SEX" |
|
| 444 |
#' ), |
|
| 445 |
#' time_points = choices_selected(c(182, 243), 182), |
|
| 446 |
#' event_desc_var = choices_selected( |
|
| 447 |
#' variable_choices(ADTTE, "EVNTDESC"), |
|
| 448 |
#' "EVNTDESC", |
|
| 449 |
#' fixed = TRUE |
|
| 450 |
#' ) |
|
| 451 |
#' ) |
|
| 452 |
#' ) |
|
| 453 |
#' ) |
|
| 454 |
#' if (interactive()) {
|
|
| 455 |
#' shinyApp(app$ui, app$server) |
|
| 456 |
#' } |
|
| 457 |
#' |
|
| 458 |
#' @export |
|
| 459 |
tm_t_tte <- function(label, |
|
| 460 |
dataname, |
|
| 461 |
parentname = ifelse( |
|
| 462 |
inherits(arm_var, "data_extract_spec"), |
|
| 463 |
teal.transform::datanames_input(arm_var), |
|
| 464 |
"ADSL" |
|
| 465 |
), |
|
| 466 |
arm_var, |
|
| 467 |
arm_ref_comp = NULL, |
|
| 468 |
paramcd, |
|
| 469 |
strata_var, |
|
| 470 |
aval_var = teal.transform::choices_selected( |
|
| 471 |
teal.transform::variable_choices(dataname, "AVAL"), "AVAL", |
|
| 472 |
fixed = TRUE |
|
| 473 |
), |
|
| 474 |
cnsr_var = teal.transform::choices_selected( |
|
| 475 |
teal.transform::variable_choices(dataname, "CNSR"), "CNSR", |
|
| 476 |
fixed = TRUE |
|
| 477 |
), |
|
| 478 |
conf_level_coxph = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 479 |
conf_level_survfit = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 480 |
time_points, |
|
| 481 |
time_unit_var = teal.transform::choices_selected( |
|
| 482 |
teal.transform::variable_choices(dataname, "AVALU"), "AVALU", |
|
| 483 |
fixed = TRUE |
|
| 484 |
), |
|
| 485 |
event_desc_var = teal.transform::choices_selected("EVNTDESC", "EVNTDESC", fixed = TRUE),
|
|
| 486 |
add_total = FALSE, |
|
| 487 |
total_label = default_total_label(), |
|
| 488 |
na_level = default_na_str(), |
|
| 489 |
pre_output = NULL, |
|
| 490 |
post_output = NULL, |
|
| 491 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 492 | ! |
message("Initializing tm_t_tte")
|
| 493 | ! |
checkmate::assert_string(label) |
| 494 | ! |
checkmate::assert_string(dataname) |
| 495 | ! |
checkmate::assert_string(parentname) |
| 496 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 497 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 498 | ! |
checkmate::assert_class(strata_var, "choices_selected") |
| 499 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 500 | ! |
checkmate::assert_class(cnsr_var, "choices_selected") |
| 501 | ! |
checkmate::assert_class(conf_level_coxph, "choices_selected") |
| 502 | ! |
checkmate::assert_class(conf_level_survfit, "choices_selected") |
| 503 | ! |
checkmate::assert_class(time_points, "choices_selected") |
| 504 | ! |
checkmate::assert_class(time_unit_var, "choices_selected") |
| 505 | ! |
checkmate::assert_flag(add_total) |
| 506 | ! |
checkmate::assert_string(total_label) |
| 507 | ! |
checkmate::assert_string(na_level) |
| 508 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 509 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 510 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 511 | ||
| 512 | ! |
args <- as.list(environment()) |
| 513 | ||
| 514 | ! |
data_extract_list <- list( |
| 515 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 516 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 517 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 518 | ! |
cnsr_var = cs_to_des_select(cnsr_var, dataname = dataname), |
| 519 | ! |
strata_var = cs_to_des_select(strata_var, dataname = parentname, multiple = TRUE), |
| 520 | ! |
event_desc_var = cs_to_des_select(event_desc_var, dataname = dataname), |
| 521 | ! |
time_unit_var = cs_to_des_select(time_unit_var, dataname = dataname) |
| 522 |
) |
|
| 523 | ||
| 524 | ! |
module( |
| 525 | ! |
label = label, |
| 526 | ! |
server = srv_t_tte, |
| 527 | ! |
ui = ui_t_tte, |
| 528 | ! |
ui_args = c(data_extract_list, args), |
| 529 | ! |
server_args = c( |
| 530 | ! |
data_extract_list, |
| 531 | ! |
list( |
| 532 | ! |
dataname = dataname, |
| 533 | ! |
parentname = parentname, |
| 534 | ! |
arm_ref_comp = arm_ref_comp, |
| 535 | ! |
label = label, |
| 536 | ! |
total_label = total_label, |
| 537 | ! |
na_level = na_level, |
| 538 | ! |
basic_table_args = basic_table_args |
| 539 |
) |
|
| 540 |
), |
|
| 541 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 542 |
) |
|
| 543 |
} |
|
| 544 | ||
| 545 |
#' @keywords internal |
|
| 546 |
ui_t_tte <- function(id, ...) {
|
|
| 547 | ! |
a <- list(...) # module args |
| 548 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 549 | ! |
a$arm_var, |
| 550 | ! |
a$paramcd, |
| 551 | ! |
a$aval_var, |
| 552 | ! |
a$cnsr_var, |
| 553 | ! |
a$strata_var, |
| 554 | ! |
a$event_desc_var, |
| 555 | ! |
a$time_unit_var |
| 556 |
) |
|
| 557 | ||
| 558 | ! |
ns <- NS(id) |
| 559 | ||
| 560 | ! |
teal.widgets::standard_layout( |
| 561 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 562 | ! |
encoding = tags$div( |
| 563 |
### Reporter |
|
| 564 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 565 |
### |
|
| 566 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 567 | ! |
teal.transform::datanames_input( |
| 568 | ! |
a[c("arm_var", "paramcd", "aval_var", "cnsr_var", "strata_var", "event_desc_var")]
|
| 569 |
), |
|
| 570 | ! |
teal.transform::data_extract_ui( |
| 571 | ! |
id = ns("paramcd"),
|
| 572 | ! |
label = "Select Endpoint", |
| 573 | ! |
data_extract_spec = a$paramcd, |
| 574 | ! |
is_single_dataset = is_single_dataset_value |
| 575 |
), |
|
| 576 | ! |
teal.transform::data_extract_ui( |
| 577 | ! |
id = ns("aval_var"),
|
| 578 | ! |
label = "Analysis Variable", |
| 579 | ! |
data_extract_spec = a$aval_var, |
| 580 | ! |
is_single_dataset = is_single_dataset_value |
| 581 |
), |
|
| 582 | ! |
teal.transform::data_extract_ui( |
| 583 | ! |
id = ns("cnsr_var"),
|
| 584 | ! |
label = "Censor Variable", |
| 585 | ! |
data_extract_spec = a$cnsr_var, |
| 586 | ! |
is_single_dataset = is_single_dataset_value |
| 587 |
), |
|
| 588 | ! |
teal.transform::data_extract_ui( |
| 589 | ! |
id = ns("arm_var"),
|
| 590 | ! |
label = "Select Treatment Variable", |
| 591 | ! |
data_extract_spec = a$arm_var, |
| 592 | ! |
is_single_dataset = is_single_dataset_value |
| 593 |
), |
|
| 594 | ! |
tags$div( |
| 595 | ! |
class = "arm-comp-box", |
| 596 | ! |
tags$label("Compare Treatments"),
|
| 597 | ! |
shinyWidgets::switchInput( |
| 598 | ! |
inputId = ns("compare_arms"),
|
| 599 | ! |
value = !is.null(a$arm_ref_comp), |
| 600 | ! |
size = "mini" |
| 601 |
), |
|
| 602 | ! |
conditionalPanel( |
| 603 | ! |
condition = paste0("input['", ns("compare_arms"), "']"),
|
| 604 | ! |
tags$div( |
| 605 | ! |
uiOutput(ns("arms_buckets")),
|
| 606 | ! |
uiOutput(ns("helptext_ui")),
|
| 607 | ! |
checkboxInput( |
| 608 | ! |
ns("combine_comp_arms"),
|
| 609 | ! |
"Combine all comparison groups?", |
| 610 | ! |
value = FALSE |
| 611 |
), |
|
| 612 | ! |
teal.transform::data_extract_ui( |
| 613 | ! |
id = ns("strata_var"),
|
| 614 | ! |
label = "Stratify by", |
| 615 | ! |
data_extract_spec = a$strata_var, |
| 616 | ! |
is_single_dataset = is_single_dataset_value |
| 617 |
) |
|
| 618 |
) |
|
| 619 |
) |
|
| 620 |
), |
|
| 621 | ! |
conditionalPanel( |
| 622 | ! |
condition = paste0("!input['", ns("compare_arms"), "']"),
|
| 623 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total)
|
| 624 |
), |
|
| 625 | ! |
teal.widgets::optionalSelectInput(ns("time_points"),
|
| 626 | ! |
"Time Points", |
| 627 | ! |
a$time_points$choices, |
| 628 | ! |
a$time_points$selected, |
| 629 | ! |
multiple = TRUE, |
| 630 | ! |
fixed = a$time_points$fixed |
| 631 |
), |
|
| 632 | ! |
teal.transform::data_extract_ui( |
| 633 | ! |
id = ns("event_desc_var"),
|
| 634 | ! |
label = "Event Description Variable", |
| 635 | ! |
data_extract_spec = a$event_desc_var, |
| 636 | ! |
is_single_dataset = is_single_dataset_value |
| 637 |
), |
|
| 638 | ! |
conditionalPanel( |
| 639 | ! |
condition = paste0("input['", ns("compare_arms"), "']"),
|
| 640 | ! |
teal.widgets::panel_item( |
| 641 | ! |
"Comparison settings", |
| 642 | ! |
radioButtons( |
| 643 | ! |
ns("pval_method_coxph"),
|
| 644 | ! |
label = HTML( |
| 645 | ! |
paste( |
| 646 | ! |
"p-value method for ", |
| 647 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 648 | ! |
" (Hazard Ratio)", |
| 649 | ! |
sep = "" |
| 650 |
) |
|
| 651 |
), |
|
| 652 | ! |
choices = c("wald", "log-rank", "likelihood"),
|
| 653 | ! |
selected = "log-rank" |
| 654 |
), |
|
| 655 | ! |
radioButtons( |
| 656 | ! |
ns("ties_coxph"),
|
| 657 | ! |
label = HTML( |
| 658 | ! |
paste( |
| 659 | ! |
"Ties for ", |
| 660 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 661 | ! |
" (Hazard Ratio)", |
| 662 | ! |
sep = "" |
| 663 |
) |
|
| 664 |
), |
|
| 665 | ! |
choices = c("exact", "breslow", "efron"),
|
| 666 | ! |
selected = "exact" |
| 667 |
), |
|
| 668 | ! |
teal.widgets::optionalSelectInput( |
| 669 | ! |
inputId = ns("conf_level_coxph"),
|
| 670 | ! |
label = HTML( |
| 671 | ! |
paste( |
| 672 | ! |
"Confidence Level for ", |
| 673 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 674 | ! |
" (Hazard Ratio)", |
| 675 | ! |
sep = "" |
| 676 |
) |
|
| 677 |
), |
|
| 678 | ! |
a$conf_level_coxph$choices, |
| 679 | ! |
a$conf_level_coxph$selected, |
| 680 | ! |
multiple = FALSE, |
| 681 | ! |
fixed = a$conf_level_coxph$fixed |
| 682 |
) |
|
| 683 |
) |
|
| 684 |
), |
|
| 685 | ! |
teal.widgets::panel_item( |
| 686 | ! |
"Additional table settings", |
| 687 | ! |
teal.widgets::optionalSelectInput( |
| 688 | ! |
inputId = ns("conf_level_survfit"),
|
| 689 | ! |
label = HTML( |
| 690 | ! |
paste( |
| 691 | ! |
"Confidence Level for ", |
| 692 | ! |
tags$span(class = "text-primary", "Survfit"), |
| 693 | ! |
" (KM Median Estimate & Event Free Rate)", |
| 694 | ! |
sep = "" |
| 695 |
) |
|
| 696 |
), |
|
| 697 | ! |
a$conf_level_survfit$choices, |
| 698 | ! |
a$conf_level_survfit$selected, |
| 699 | ! |
multiple = FALSE, |
| 700 | ! |
fixed = a$conf_level_survfit$fixed |
| 701 |
), |
|
| 702 | ! |
radioButtons( |
| 703 | ! |
ns("conf_type_survfit"),
|
| 704 | ! |
"Confidence Level Type for Survfit", |
| 705 | ! |
choices = c("plain", "log", "log-log"),
|
| 706 | ! |
selected = "plain" |
| 707 |
), |
|
| 708 | ! |
sliderInput( |
| 709 | ! |
inputId = ns("probs_survfit"),
|
| 710 | ! |
label = "KM Estimate Percentiles", |
| 711 | ! |
min = 0.01, |
| 712 | ! |
max = 0.99, |
| 713 | ! |
value = c(0.25, 0.75), |
| 714 | ! |
width = "100%" |
| 715 |
), |
|
| 716 | ! |
teal.transform::data_extract_ui( |
| 717 | ! |
id = ns("time_unit_var"),
|
| 718 | ! |
label = "Time Unit Variable", |
| 719 | ! |
data_extract_spec = a$time_unit_var, |
| 720 | ! |
is_single_dataset = is_single_dataset_value |
| 721 |
) |
|
| 722 |
) |
|
| 723 |
), |
|
| 724 | ! |
forms = tagList( |
| 725 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 726 |
), |
|
| 727 | ! |
pre_output = a$pre_output, |
| 728 | ! |
post_output = a$post_output |
| 729 |
) |
|
| 730 |
} |
|
| 731 | ||
| 732 |
#' @keywords internal |
|
| 733 |
srv_t_tte <- function(id, |
|
| 734 |
data, |
|
| 735 |
filter_panel_api, |
|
| 736 |
reporter, |
|
| 737 |
arm_var, |
|
| 738 |
paramcd, |
|
| 739 |
aval_var, |
|
| 740 |
cnsr_var, |
|
| 741 |
strata_var, |
|
| 742 |
event_desc_var, |
|
| 743 |
dataname, |
|
| 744 |
parentname, |
|
| 745 |
arm_ref_comp, |
|
| 746 |
time_unit_var, |
|
| 747 |
add_total, |
|
| 748 |
total_label, |
|
| 749 |
label, |
|
| 750 |
na_level, |
|
| 751 |
basic_table_args) {
|
|
| 752 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 753 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 754 | ! |
checkmate::assert_class(data, "reactive") |
| 755 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 756 | ! |
moduleServer(id, function(input, output, session) {
|
| 757 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 758 |
# Setup arm variable selection, default reference arms, and default |
|
| 759 |
# comparison arms for encoding panel |
|
| 760 | ! |
iv_arm_ref <- arm_ref_comp_observer( |
| 761 | ! |
session, |
| 762 | ! |
input, |
| 763 | ! |
output, |
| 764 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 765 | ! |
data = reactive(data()[[parentname]]), |
| 766 | ! |
arm_ref_comp = arm_ref_comp, |
| 767 | ! |
module = "tm_t_tte", |
| 768 | ! |
on_off = reactive(input$compare_arms) |
| 769 |
) |
|
| 770 | ||
| 771 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 772 | ! |
data_extract = list( |
| 773 | ! |
arm_var = arm_var, |
| 774 | ! |
paramcd = paramcd, |
| 775 | ! |
aval_var = aval_var, |
| 776 | ! |
cnsr_var = cnsr_var, |
| 777 | ! |
strata_var = strata_var, |
| 778 | ! |
event_desc_var = event_desc_var, |
| 779 | ! |
time_unit_var = time_unit_var |
| 780 |
), |
|
| 781 | ! |
datasets = data, |
| 782 | ! |
select_validation_rule = list( |
| 783 | ! |
aval_var = shinyvalidate::sv_required("An analysis variable is required"),
|
| 784 | ! |
cnsr_var = shinyvalidate::sv_required("A censor variable is required"),
|
| 785 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required"),
|
| 786 | ! |
event_desc_var = shinyvalidate::sv_required("An event description variable is required"),
|
| 787 | ! |
time_unit_var = shinyvalidate::sv_required("A Time unit variable is required")
|
| 788 |
), |
|
| 789 | ! |
filter_validation_rule = list( |
| 790 | ! |
paramcd = shinyvalidate::sv_required("An endpoint is required")
|
| 791 |
) |
|
| 792 |
) |
|
| 793 | ||
| 794 | ! |
output$helptext_ui <- renderUI({
|
| 795 | ! |
req(selector_list()$arm_var()$select) |
| 796 | ! |
helpText("Multiple reference groups are automatically combined into a single group.")
|
| 797 |
}) |
|
| 798 | ||
| 799 | ! |
iv_r <- reactive({
|
| 800 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 801 | ||
| 802 | ! |
if (isTRUE(input$compare_arms)) {
|
| 803 | ! |
iv$add_validator(iv_arm_ref) |
| 804 |
} |
|
| 805 | ||
| 806 | ! |
iv$add_rule("conf_level_coxph", shinyvalidate::sv_required("Please choose a hazard ratio confidence level"))
|
| 807 | ! |
iv$add_rule( |
| 808 | ! |
"conf_level_coxph", shinyvalidate::sv_between( |
| 809 | ! |
0, 1, |
| 810 | ! |
message_fmt = "Hazard ratio confidence level must between 0 and 1" |
| 811 |
) |
|
| 812 |
) |
|
| 813 | ! |
iv$add_rule("conf_level_survfit", shinyvalidate::sv_required("Please choose a KM confidence level"))
|
| 814 | ! |
iv$add_rule( |
| 815 | ! |
"conf_level_survfit", shinyvalidate::sv_between( |
| 816 | ! |
0, 1, |
| 817 | ! |
message_fmt = "KM confidence level must between 0 and 1" |
| 818 |
) |
|
| 819 |
) |
|
| 820 | ! |
iv$add_rule( |
| 821 | ! |
"probs_survfit", |
| 822 | ! |
~ if (!is.null(.) && .[1] == .[2]) "KM Estimate Percentiles cannot have a range of size 0" |
| 823 |
) |
|
| 824 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 825 |
}) |
|
| 826 | ||
| 827 | ! |
anl_merge_inputs <- teal.transform::merge_expression_srv( |
| 828 | ! |
datasets = data, |
| 829 | ! |
selector_list = selector_list, |
| 830 | ! |
merge_function = "dplyr::inner_join" |
| 831 |
) |
|
| 832 | ||
| 833 | ! |
adsl_merge_inputs <- teal.transform::merge_expression_module( |
| 834 | ! |
datasets = data, |
| 835 | ! |
join_keys = teal.data::join_keys(data), |
| 836 | ! |
data_extract = list(arm_var = arm_var, strata_var = strata_var), |
| 837 | ! |
anl_name = "ANL_ADSL" |
| 838 |
) |
|
| 839 | ||
| 840 | ! |
anl_q <- reactive({
|
| 841 | ! |
data() %>% |
| 842 | ! |
teal.code::eval_code(as.expression(anl_merge_inputs()$expr)) %>% |
| 843 | ! |
teal.code::eval_code(as.expression(adsl_merge_inputs()$expr)) |
| 844 |
}) |
|
| 845 | ||
| 846 |
# Prepare the analysis environment (filter data, check data, populate envir). |
|
| 847 | ! |
validate_checks <- reactive({
|
| 848 | ! |
teal::validate_inputs(iv_r()) |
| 849 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 850 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 851 | ! |
anl <- anl_q()[["ANL"]] |
| 852 | ||
| 853 | ! |
anl_m <- anl_merge_inputs() |
| 854 | ! |
input_arm_var <- as.vector(anl_m$columns_source$arm_var) |
| 855 | ! |
input_strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 856 | ! |
input_aval_var <- as.vector(anl_m$columns_source$aval_var) |
| 857 | ! |
input_cnsr_var <- as.vector(anl_m$columns_source$cnsr_var) |
| 858 | ! |
input_event_desc <- as.vector(anl_m$columns_source$event_desc_var) |
| 859 | ! |
input_time_unit_var <- as.vector(anl_m$columns_source$time_unit_var) |
| 860 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 861 | ||
| 862 |
# validate inputs |
|
| 863 | ! |
validate_args <- list( |
| 864 | ! |
adsl = adsl_filtered, |
| 865 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var, input_strata_var),
|
| 866 | ! |
anl = anl_filtered, |
| 867 | ! |
anlvars = c( |
| 868 | ! |
"USUBJID", "STUDYID", input_paramcd, input_aval_var, |
| 869 | ! |
input_cnsr_var, input_event_desc, input_time_unit_var |
| 870 |
), |
|
| 871 | ! |
arm_var = input_arm_var |
| 872 |
) |
|
| 873 | ||
| 874 |
# validate arm levels |
|
| 875 | ! |
if (length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) == 1) {
|
| 876 | ! |
validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) |
| 877 |
} |
|
| 878 | ! |
if (isTRUE(input$compare_arms)) {
|
| 879 | ! |
validate_args <- append( |
| 880 | ! |
validate_args, |
| 881 | ! |
list(ref_arm = unlist(input$buckets$Ref), comp_arm = unlist(input$buckets$Comp)) |
| 882 |
) |
|
| 883 |
} |
|
| 884 | ||
| 885 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 886 | ||
| 887 |
# check that there is at least one record with no missing data |
|
| 888 | ! |
validate(shiny::need( |
| 889 | ! |
!all(is.na(anl[[input_aval_var]])), |
| 890 | ! |
"ANCOVA table cannot be calculated as all values are missing." |
| 891 |
)) |
|
| 892 | ||
| 893 | ! |
NULL |
| 894 |
}) |
|
| 895 | ||
| 896 |
# The R-code corresponding to the analysis. |
|
| 897 | ||
| 898 | ! |
all_q <- reactive({
|
| 899 | ! |
validate_checks() |
| 900 | ||
| 901 | ! |
anl_m <- anl_merge_inputs() |
| 902 | ||
| 903 | ! |
strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 904 | ||
| 905 | ! |
my_calls <- template_tte( |
| 906 | ! |
dataname = "ANL", |
| 907 | ! |
parentname = "ANL_ADSL", |
| 908 | ! |
arm_var = as.vector(anl_m$columns_source$arm_var), |
| 909 | ! |
paramcd = unlist(anl_m$filter_info$paramcd)["selected"], |
| 910 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 911 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 912 | ! |
compare_arm = input$compare_arms, |
| 913 | ! |
combine_comp_arms = input$combine_comp_arms && input$compare_arms, |
| 914 | ! |
aval_var = as.vector(anl_m$columns_source$aval_var), |
| 915 | ! |
cnsr_var = as.vector(anl_m$columns_source$cnsr_var), |
| 916 | ! |
strata_var = if (length(strata_var) != 0) strata_var else NULL, |
| 917 | ! |
time_points = as.numeric(input$time_points), |
| 918 | ! |
time_unit_var = as.vector(anl_m$columns_source$time_unit_var), |
| 919 | ! |
event_desc_var = as.vector(anl_m$columns_source$event_desc_var), |
| 920 | ! |
control = control_tte( |
| 921 | ! |
coxph = control_coxph( |
| 922 | ! |
pval_method = input$pval_method_coxph, |
| 923 | ! |
ties = input$ties_coxph, |
| 924 | ! |
conf_level = as.numeric(input$conf_level_coxph) |
| 925 |
), |
|
| 926 | ! |
surv_time = control_surv_time( |
| 927 | ! |
conf_level = as.numeric(input$conf_level_survfit), |
| 928 | ! |
conf_type = input$conf_type_survfit, |
| 929 | ! |
quantiles = input$probs_survfit |
| 930 |
), |
|
| 931 | ! |
surv_timepoint = control_surv_timepoint( |
| 932 | ! |
conf_level = as.numeric(input$conf_level_survfit), |
| 933 | ! |
conf_type = input$conf_type_survfit |
| 934 |
) |
|
| 935 |
), |
|
| 936 | ! |
add_total = input$add_total, |
| 937 | ! |
total_label = total_label, |
| 938 | ! |
na_level = na_level, |
| 939 | ! |
basic_table_args = basic_table_args |
| 940 |
) |
|
| 941 | ||
| 942 | ! |
anl_q() %>% teal.code::eval_code(as.expression(my_calls)) |
| 943 |
}) |
|
| 944 | ||
| 945 | ! |
table_r <- reactive(all_q()[["table"]]) |
| 946 | ||
| 947 | ! |
teal.widgets::table_with_settings_srv(id = "table", table_r = table_r) |
| 948 | ||
| 949 | ! |
teal.widgets::verbatim_popup_srv( |
| 950 | ! |
id = "rcode", |
| 951 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 952 | ! |
title = label |
| 953 |
) |
|
| 954 | ||
| 955 |
### REPORTER |
|
| 956 | ! |
if (with_reporter) {
|
| 957 | ! |
card_fun <- function(comment, label) {
|
| 958 | ! |
card <- teal::report_card_template( |
| 959 | ! |
title = "Time To Event Table", |
| 960 | ! |
label = label, |
| 961 | ! |
with_filter = with_filter, |
| 962 | ! |
filter_panel_api = filter_panel_api |
| 963 |
) |
|
| 964 | ! |
card$append_text("Table", "header3")
|
| 965 | ! |
card$append_table(table_r()) |
| 966 | ! |
if (!comment == "") {
|
| 967 | ! |
card$append_text("Comment", "header3")
|
| 968 | ! |
card$append_text(comment) |
| 969 |
} |
|
| 970 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 971 | ! |
card |
| 972 |
} |
|
| 973 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 974 |
} |
|
| 975 |
### |
|
| 976 |
}) |
|
| 977 |
} |
| 1 |
#' Template: Abnormality Summary Table |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table to summarize abnormality. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param exclude_base_abn (`logical`)\cr whether to exclude patients who had abnormal values at baseline. |
|
| 7 |
#' @param grade (`character`)\cr name of the variable used to |
|
| 8 |
#' specify the abnormality grade. Variable must be factor. |
|
| 9 |
#' @param abnormal (`named list`)\cr indicating abnormality direction and grades. |
|
| 10 |
#' @param baseline_var (`character`)\cr |
|
| 11 |
#' name of the variable specifying baseline abnormality grade. |
|
| 12 |
#' @param na_level (`character`)\cr the NA level in the input dataset, defaults to `"<Missing>"`. |
|
| 13 |
#' @param tbl_title (`character`)\cr Title with label of variables from by bars |
|
| 14 |
#' |
|
| 15 |
#' @inherit template_arguments return |
|
| 16 |
#' |
|
| 17 |
#' @seealso [tm_t_abnormality()] |
|
| 18 |
#' @keywords internal |
|
| 19 |
#' |
|
| 20 |
template_abnormality <- function(parentname, |
|
| 21 |
dataname, |
|
| 22 |
arm_var, |
|
| 23 |
id_var = "USUBJID", |
|
| 24 |
by_vars, |
|
| 25 |
abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
|
|
| 26 |
grade = "ANRIND", |
|
| 27 |
baseline_var = "BNRIND", |
|
| 28 |
treatment_flag_var = "ONTRTFL", |
|
| 29 |
treatment_flag = "Y", |
|
| 30 |
add_total = FALSE, |
|
| 31 |
total_label = default_total_label(), |
|
| 32 |
exclude_base_abn = FALSE, |
|
| 33 |
drop_arm_levels = TRUE, |
|
| 34 |
na_level = default_na_str(), |
|
| 35 |
basic_table_args = teal.widgets::basic_table_args(), |
|
| 36 |
tbl_title) {
|
|
| 37 | 3x |
checkmate::assert_string(dataname) |
| 38 | 3x |
checkmate::assert_string(id_var) |
| 39 | 3x |
checkmate::assert_string(parentname) |
| 40 | 3x |
checkmate::assert_string(arm_var) |
| 41 | 3x |
checkmate::check_character(by_vars) |
| 42 | 3x |
checkmate::check_list(abnormal) |
| 43 | 3x |
checkmate::assert_string(grade) |
| 44 | 3x |
checkmate::assert_string(baseline_var) |
| 45 | 3x |
checkmate::assert_string(treatment_flag_var) |
| 46 | 3x |
checkmate::assert_string(treatment_flag) |
| 47 | 3x |
checkmate::assert_flag(add_total) |
| 48 | 3x |
checkmate::assert_string(total_label) |
| 49 | 3x |
checkmate::assert_flag(exclude_base_abn) |
| 50 | 3x |
checkmate::assert_flag(drop_arm_levels) |
| 51 | 3x |
checkmate::assert_string(tbl_title) |
| 52 | ||
| 53 | 3x |
y <- list() |
| 54 | ||
| 55 | 3x |
data_list <- list() |
| 56 | ||
| 57 | 3x |
data_list <- add_expr( |
| 58 | 3x |
data_list, |
| 59 | 3x |
substitute( |
| 60 | 3x |
expr = anl <- df %>% |
| 61 | 3x |
dplyr::filter(treatment_flag_var == treatment_flag & !is.na(grade) & grade != na_level), |
| 62 | 3x |
env = list( |
| 63 | 3x |
df = as.name(dataname), |
| 64 | 3x |
grade = as.name(grade), |
| 65 | 3x |
treatment_flag_var = as.name(treatment_flag_var), |
| 66 | 3x |
treatment_flag = treatment_flag, |
| 67 | 3x |
na_level = na_level |
| 68 |
) |
|
| 69 |
) |
|
| 70 |
) |
|
| 71 | ||
| 72 | 3x |
data_list <- add_expr( |
| 73 | 3x |
data_list, |
| 74 | 3x |
prepare_arm_levels( |
| 75 | 3x |
dataname = "anl", |
| 76 | 3x |
parentname = parentname, |
| 77 | 3x |
arm_var = arm_var, |
| 78 | 3x |
drop_arm_levels = drop_arm_levels |
| 79 |
) |
|
| 80 |
) |
|
| 81 | ||
| 82 | 3x |
data_list <- add_expr( |
| 83 | 3x |
data_list, |
| 84 | 3x |
substitute( |
| 85 | 3x |
dataname <- df_explicit_na(dataname, na_level = na_level), |
| 86 | 3x |
env = list(dataname = as.name("anl"), na_level = na_level)
|
| 87 |
) |
|
| 88 |
) |
|
| 89 | ||
| 90 | 3x |
data_list <- add_expr( |
| 91 | 3x |
data_list, |
| 92 | 3x |
substitute( |
| 93 | 3x |
parentname <- df_explicit_na(parentname, na_level = na_level), |
| 94 | 3x |
env = list(parentname = as.name(parentname), na_level = na_level) |
| 95 |
) |
|
| 96 |
) |
|
| 97 | ||
| 98 | 3x |
y$data <- bracket_expr(data_list) |
| 99 | ||
| 100 |
# layout start |
|
| 101 | 3x |
prep_list <- list() |
| 102 | 3x |
prep_list <- add_expr( |
| 103 | 3x |
prep_list, |
| 104 | 3x |
substitute( |
| 105 |
# Define the map for layout using helper function h_map_for_count_abnormal |
|
| 106 | 3x |
map <- h_map_for_count_abnormal( |
| 107 | 3x |
df = dataname, |
| 108 | 3x |
variables = list(anl = grade, split_rows = by_vars), |
| 109 | 3x |
abnormal = abnormal, |
| 110 | 3x |
method = "default", |
| 111 | 3x |
na_str = na_level |
| 112 |
), |
|
| 113 | 3x |
env = list(dataname = as.name("anl"), by_vars = by_vars, grade = grade, abnormal = abnormal, na_level = na_level)
|
| 114 |
) |
|
| 115 |
) |
|
| 116 | ||
| 117 | 3x |
y$layout_prep <- bracket_expr(prep_list) |
| 118 | ||
| 119 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 120 | 3x |
teal.widgets::resolve_basic_table_args( |
| 121 | 3x |
user_table = basic_table_args, |
| 122 | 3x |
module_table = teal.widgets::basic_table_args( |
| 123 | 3x |
show_colcounts = TRUE, |
| 124 | 3x |
title = tbl_title, |
| 125 | 3x |
main_footer = "Variables without observed abnormalities are excluded." |
| 126 |
) |
|
| 127 |
) |
|
| 128 |
) |
|
| 129 | ||
| 130 | 3x |
layout_list <- list() |
| 131 | ||
| 132 | ||
| 133 | 3x |
layout_list <- add_expr( |
| 134 | 3x |
layout_list, |
| 135 | 3x |
if (add_total) {
|
| 136 | 1x |
substitute( |
| 137 | 1x |
expr = expr_basic_table_args %>% |
| 138 | 1x |
rtables::split_cols_by( |
| 139 | 1x |
var = arm_var, |
| 140 | 1x |
split_fun = add_overall_level(total_label, first = FALSE) |
| 141 |
), |
|
| 142 | 1x |
env = list( |
| 143 | 1x |
arm_var = arm_var, |
| 144 | 1x |
total_label = total_label, |
| 145 | 1x |
expr_basic_table_args = parsed_basic_table_args |
| 146 |
) |
|
| 147 |
) |
|
| 148 |
} else {
|
|
| 149 | 2x |
substitute( |
| 150 | 2x |
expr = expr_basic_table_args %>% |
| 151 | 2x |
rtables::split_cols_by(var = arm_var), |
| 152 | 2x |
env = list(arm_var = arm_var, expr_basic_table_args = parsed_basic_table_args) |
| 153 |
) |
|
| 154 |
} |
|
| 155 |
) |
|
| 156 | ||
| 157 | 3x |
for (by_var in by_vars) {
|
| 158 | 6x |
split_label <- substitute( |
| 159 | 6x |
expr = teal.data::col_labels(dataname, fill = FALSE)[[by_var]], |
| 160 | 6x |
env = list( |
| 161 | 6x |
dataname = as.name(dataname), |
| 162 | 6x |
by_var = by_var |
| 163 |
) |
|
| 164 |
) |
|
| 165 | 6x |
layout_list <- add_expr( |
| 166 | 6x |
layout_list, |
| 167 | 6x |
substitute( |
| 168 | 6x |
rtables::split_rows_by( |
| 169 | 6x |
by_var, |
| 170 | 6x |
split_label = split_label, |
| 171 | 6x |
label_pos = "topleft", |
| 172 | 6x |
split_fun = trim_levels_to_map(map = map) |
| 173 |
), |
|
| 174 | 6x |
env = list( |
| 175 | 6x |
by_var = by_var, |
| 176 | 6x |
split_label = split_label, |
| 177 | 6x |
map = as.name("map")
|
| 178 |
) |
|
| 179 |
) |
|
| 180 |
) |
|
| 181 |
} |
|
| 182 | ||
| 183 | 3x |
layout_list <- add_expr( |
| 184 | 3x |
layout_list, |
| 185 | 3x |
substitute( |
| 186 | 3x |
expr = count_abnormal( |
| 187 | 3x |
var = grade, |
| 188 | 3x |
abnormal = abnormal, |
| 189 | 3x |
variables = list(id = id_var, baseline = baseline_var), |
| 190 | 3x |
.indent_mods = 4L, |
| 191 | 3x |
exclude_base_abn = exclude_base_abn |
| 192 |
) %>% |
|
| 193 | 3x |
append_varlabels(dataname, grade, indent = indent_space), |
| 194 | 3x |
env = list( |
| 195 | 3x |
grade = grade, |
| 196 | 3x |
abnormal = abnormal, |
| 197 | 3x |
id_var = id_var, |
| 198 | 3x |
baseline_var = baseline_var, |
| 199 | 3x |
exclude_base_abn = exclude_base_abn, |
| 200 | 3x |
dataname = as.name(dataname), |
| 201 | 3x |
by_vars = by_vars, |
| 202 | 3x |
indent_space = length(by_vars) |
| 203 |
) |
|
| 204 |
) |
|
| 205 |
) |
|
| 206 | ||
| 207 | 3x |
y$layout <- substitute( |
| 208 | 3x |
expr = lyt <- layout_pipe, |
| 209 | 3x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 210 |
) |
|
| 211 | ||
| 212 | 3x |
y$table <- substitute( |
| 213 | 3x |
expr = {
|
| 214 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) %>% |
| 215 | ! |
rtables::prune_table() |
| 216 | ! |
result |
| 217 |
}, |
|
| 218 | 3x |
env = list(parent = as.name(parentname)) |
| 219 |
) |
|
| 220 | ||
| 221 | 3x |
y |
| 222 |
} |
|
| 223 | ||
| 224 |
#' teal Module: Abnormality Summary Table |
|
| 225 |
#' |
|
| 226 |
#' This module produces a table to summarize abnormality. |
|
| 227 |
#' |
|
| 228 |
#' @inheritParams module_arguments |
|
| 229 |
#' @inheritParams template_abnormality |
|
| 230 |
#' @param grade ([teal.transform::choices_selected()])\cr |
|
| 231 |
#' object with all available choices and preselected option for variable names that can be used to |
|
| 232 |
#' specify the abnormality grade. Variable must be factor. |
|
| 233 |
#' @param abnormal (`named list`)\cr defined by user to indicate what abnormalities are to be displayed. |
|
| 234 |
#' @param baseline_var ([teal.transform::choices_selected()])\cr |
|
| 235 |
#' variable for baseline abnormality grade. |
|
| 236 |
#' @param na_level (`character`)\cr the NA level in the input dataset, default to `"<Missing>"`. |
|
| 237 |
#' |
|
| 238 |
#' @inherit module_arguments return seealso |
|
| 239 |
#' |
|
| 240 |
#' @note Patients with the same abnormality at baseline as on the treatment visit can be |
|
| 241 |
#' excluded in accordance with GDSR specifications by using `exclude_base_abn`. |
|
| 242 |
#' |
|
| 243 |
#' @examples |
|
| 244 |
#' |
|
| 245 |
#' data <- teal_data() |
|
| 246 |
#' data <- within(data, {
|
|
| 247 |
#' library(dplyr) |
|
| 248 |
#' |
|
| 249 |
#' ADSL <- tmc_ex_adsl |
|
| 250 |
#' ADLB <- tmc_ex_adlb %>% |
|
| 251 |
#' mutate( |
|
| 252 |
#' ONTRTFL = case_when( |
|
| 253 |
#' AVISIT %in% c("SCREENING", "BASELINE") ~ "",
|
|
| 254 |
#' TRUE ~ "Y" |
|
| 255 |
#' ) %>% with_label("On Treatment Record Flag")
|
|
| 256 |
#' ) |
|
| 257 |
#' }) |
|
| 258 |
#' datanames <- c("ADSL", "ADLB")
|
|
| 259 |
#' datanames(data) <- datanames |
|
| 260 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 261 |
#' |
|
| 262 |
#' app <- init( |
|
| 263 |
#' data = data, |
|
| 264 |
#' modules = modules( |
|
| 265 |
#' tm_t_abnormality( |
|
| 266 |
#' label = "Abnormality Table", |
|
| 267 |
#' dataname = "ADLB", |
|
| 268 |
#' arm_var = choices_selected( |
|
| 269 |
#' choices = variable_choices(data[["ADSL"]], subset = c("ARM", "ARMCD")),
|
|
| 270 |
#' selected = "ARM" |
|
| 271 |
#' ), |
|
| 272 |
#' add_total = FALSE, |
|
| 273 |
#' by_vars = choices_selected( |
|
| 274 |
#' choices = variable_choices(data[["ADLB"]], subset = c("LBCAT", "PARAM", "AVISIT")),
|
|
| 275 |
#' selected = c("LBCAT", "PARAM"),
|
|
| 276 |
#' keep_order = TRUE |
|
| 277 |
#' ), |
|
| 278 |
#' baseline_var = choices_selected( |
|
| 279 |
#' variable_choices(data[["ADLB"]], subset = "BNRIND"), |
|
| 280 |
#' selected = "BNRIND", fixed = TRUE |
|
| 281 |
#' ), |
|
| 282 |
#' grade = choices_selected( |
|
| 283 |
#' choices = variable_choices(data[["ADLB"]], subset = "ANRIND"), |
|
| 284 |
#' selected = "ANRIND", |
|
| 285 |
#' fixed = TRUE |
|
| 286 |
#' ), |
|
| 287 |
#' abnormal = list(low = "LOW", high = "HIGH"), |
|
| 288 |
#' exclude_base_abn = FALSE |
|
| 289 |
#' ) |
|
| 290 |
#' ) |
|
| 291 |
#' ) |
|
| 292 |
#' if (interactive()) {
|
|
| 293 |
#' shinyApp(app$ui, app$server) |
|
| 294 |
#' } |
|
| 295 |
#' |
|
| 296 |
#' @export |
|
| 297 |
tm_t_abnormality <- function(label, |
|
| 298 |
dataname, |
|
| 299 |
parentname = ifelse( |
|
| 300 |
inherits(arm_var, "data_extract_spec"), |
|
| 301 |
teal.transform::datanames_input(arm_var), |
|
| 302 |
"ADSL" |
|
| 303 |
), |
|
| 304 |
arm_var, |
|
| 305 |
by_vars, |
|
| 306 |
grade, |
|
| 307 |
abnormal = list(low = c("LOW", "LOW LOW"), high = c("HIGH", "HIGH HIGH")),
|
|
| 308 |
id_var = teal.transform::choices_selected( |
|
| 309 |
teal.transform::variable_choices(dataname, subset = "USUBJID"), |
|
| 310 |
selected = "USUBJID", fixed = TRUE |
|
| 311 |
), |
|
| 312 |
baseline_var = teal.transform::choices_selected( |
|
| 313 |
teal.transform::variable_choices(dataname, subset = "BNRIND"), |
|
| 314 |
selected = "BNRIND", fixed = TRUE |
|
| 315 |
), |
|
| 316 |
treatment_flag_var = teal.transform::choices_selected( |
|
| 317 |
teal.transform::variable_choices(dataname, subset = "ONTRTFL"), |
|
| 318 |
selected = "ONTRTFL", fixed = TRUE |
|
| 319 |
), |
|
| 320 |
treatment_flag = teal.transform::choices_selected("Y"),
|
|
| 321 |
add_total = TRUE, |
|
| 322 |
total_label = default_total_label(), |
|
| 323 |
exclude_base_abn = FALSE, |
|
| 324 |
drop_arm_levels = TRUE, |
|
| 325 |
pre_output = NULL, |
|
| 326 |
post_output = NULL, |
|
| 327 |
na_level = default_na_str(), |
|
| 328 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 329 | ! |
message("Initializing tm_t_abnormality")
|
| 330 | ! |
checkmate::assert_string(label) |
| 331 | ! |
checkmate::assert_string(dataname) |
| 332 | ! |
checkmate::assert_string(parentname) |
| 333 | ! |
checkmate::assert_string(na_level) |
| 334 | ! |
checkmate::assert_list(abnormal, types = "character", len = 2) |
| 335 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 336 | ! |
checkmate::assert_class(by_vars, "choices_selected") |
| 337 | ! |
checkmate::assert_class(grade, "choices_selected") |
| 338 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 339 | ! |
checkmate::assert_class(baseline_var, "choices_selected") |
| 340 | ! |
checkmate::assert_class(treatment_flag_var, "choices_selected") |
| 341 | ! |
checkmate::assert_class(treatment_flag, "choices_selected") |
| 342 | ! |
checkmate::assert_flag(add_total) |
| 343 | ! |
checkmate::assert_string(total_label) |
| 344 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 345 | ! |
checkmate::assert_flag(exclude_base_abn) |
| 346 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 347 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 348 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 349 | ||
| 350 | ! |
data_extract_list <- list( |
| 351 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 352 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 353 | ! |
by_vars = cs_to_des_select(by_vars, dataname = dataname, multiple = TRUE, ordered = TRUE), |
| 354 | ! |
grade = cs_to_des_select(grade, dataname = dataname), |
| 355 | ! |
baseline_var = cs_to_des_select(baseline_var, dataname = dataname), |
| 356 | ! |
treatment_flag_var = cs_to_des_select(treatment_flag_var, dataname = dataname) |
| 357 |
) |
|
| 358 | ||
| 359 | ! |
args <- as.list(environment()) |
| 360 | ||
| 361 | ! |
module( |
| 362 | ! |
label = label, |
| 363 | ! |
ui = ui_t_abnormality, |
| 364 | ! |
server = srv_t_abnormality, |
| 365 | ! |
ui_args = c(data_extract_list, args), |
| 366 | ! |
server_args = c( |
| 367 | ! |
data_extract_list, |
| 368 | ! |
list( |
| 369 | ! |
dataname = dataname, |
| 370 | ! |
parentname = parentname, |
| 371 | ! |
abnormal = abnormal, |
| 372 | ! |
treatment_flag = treatment_flag, |
| 373 | ! |
label = label, |
| 374 | ! |
total_label = total_label, |
| 375 | ! |
na_level = na_level, |
| 376 | ! |
basic_table_args = basic_table_args |
| 377 |
) |
|
| 378 |
), |
|
| 379 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 380 |
) |
|
| 381 |
} |
|
| 382 | ||
| 383 |
#' @keywords internal |
|
| 384 |
ui_t_abnormality <- function(id, ...) {
|
|
| 385 | ! |
ns <- NS(id) |
| 386 | ! |
a <- list(...) # module args |
| 387 | ||
| 388 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 389 | ! |
a$arm_var, |
| 390 | ! |
a$id_var, |
| 391 | ! |
a$by_vars, |
| 392 | ! |
a$grade, |
| 393 | ! |
a$baseline_var, |
| 394 | ! |
a$treatment_flag_var, |
| 395 | ! |
a$treatment_flag |
| 396 |
) |
|
| 397 | ||
| 398 | ! |
teal.widgets::standard_layout( |
| 399 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 400 | ! |
encoding = tags$div( |
| 401 |
### Reporter |
|
| 402 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 403 |
### |
|
| 404 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 405 | ! |
teal.transform::datanames_input( |
| 406 | ! |
a[c("arm_var", "id_var", "by_vars", "grade", "baseline_var", "treatment_flag_var")]
|
| 407 |
), |
|
| 408 | ! |
teal.transform::data_extract_ui( |
| 409 | ! |
id = ns("arm_var"),
|
| 410 | ! |
label = "Select Treatment Variable", |
| 411 | ! |
data_extract_spec = a$arm_var, |
| 412 | ! |
is_single_dataset = is_single_dataset_value |
| 413 |
), |
|
| 414 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total),
|
| 415 | ! |
teal.transform::data_extract_ui( |
| 416 | ! |
id = ns("by_vars"),
|
| 417 | ! |
label = "Row By Variable", |
| 418 | ! |
data_extract_spec = a$by_vars, |
| 419 | ! |
is_single_dataset = is_single_dataset_value |
| 420 |
), |
|
| 421 | ! |
teal.transform::data_extract_ui( |
| 422 | ! |
id = ns("grade"),
|
| 423 | ! |
label = "Grade Variable", |
| 424 | ! |
data_extract_spec = a$grade, |
| 425 | ! |
is_single_dataset = is_single_dataset_value |
| 426 |
), |
|
| 427 | ! |
checkboxInput( |
| 428 | ! |
ns("exclude_base_abn"),
|
| 429 | ! |
"Exclude subjects whose baseline grade is the same as abnormal grade", |
| 430 | ! |
value = a$exclude_base_abn |
| 431 |
), |
|
| 432 | ! |
teal.widgets::panel_group( |
| 433 | ! |
teal.widgets::panel_item( |
| 434 | ! |
"Additional table settings", |
| 435 | ! |
checkboxInput( |
| 436 | ! |
ns("drop_arm_levels"),
|
| 437 | ! |
label = "Drop columns not in filtered analysis dataset", |
| 438 | ! |
value = a$drop_arm_levels |
| 439 |
) |
|
| 440 |
) |
|
| 441 |
), |
|
| 442 | ! |
teal.widgets::panel_group( |
| 443 | ! |
teal.widgets::panel_item( |
| 444 | ! |
"Additional Variables Info", |
| 445 | ! |
teal.transform::data_extract_ui( |
| 446 | ! |
id = ns("id_var"),
|
| 447 | ! |
label = "Subject Identifier", |
| 448 | ! |
data_extract_spec = a$id_var, |
| 449 | ! |
is_single_dataset = is_single_dataset_value |
| 450 |
), |
|
| 451 | ! |
teal.transform::data_extract_ui( |
| 452 | ! |
id = ns("baseline_var"),
|
| 453 | ! |
label = "Baseline Grade Variable", |
| 454 | ! |
data_extract_spec = a$baseline_var, |
| 455 | ! |
is_single_dataset = is_single_dataset_value |
| 456 |
), |
|
| 457 | ! |
teal.transform::data_extract_ui( |
| 458 | ! |
id = ns("treatment_flag_var"),
|
| 459 | ! |
label = "On Treatment Flag Variable", |
| 460 | ! |
data_extract_spec = a$treatment_flag_var, |
| 461 | ! |
is_single_dataset = is_single_dataset_value |
| 462 |
), |
|
| 463 | ! |
teal.widgets::optionalSelectInput( |
| 464 | ! |
ns("treatment_flag"),
|
| 465 | ! |
label = "Value Indicating On Treatment", |
| 466 | ! |
multiple = FALSE, |
| 467 | ! |
fixed_on_single = TRUE |
| 468 |
) |
|
| 469 |
) |
|
| 470 |
) |
|
| 471 |
), |
|
| 472 | ! |
forms = tagList( |
| 473 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 474 |
), |
|
| 475 | ! |
pre_output = a$pre_output, |
| 476 | ! |
post_output = a$post_output |
| 477 |
) |
|
| 478 |
} |
|
| 479 | ||
| 480 |
#' @keywords internal |
|
| 481 |
srv_t_abnormality <- function(id, |
|
| 482 |
data, |
|
| 483 |
reporter, |
|
| 484 |
filter_panel_api, |
|
| 485 |
dataname, |
|
| 486 |
parentname, |
|
| 487 |
abnormal, |
|
| 488 |
arm_var, |
|
| 489 |
id_var, |
|
| 490 |
by_vars, |
|
| 491 |
grade, |
|
| 492 |
baseline_var, |
|
| 493 |
treatment_flag_var, |
|
| 494 |
treatment_flag, |
|
| 495 |
add_total, |
|
| 496 |
total_label, |
|
| 497 |
drop_arm_levels, |
|
| 498 |
label, |
|
| 499 |
na_level, |
|
| 500 |
basic_table_args) {
|
|
| 501 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 502 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 503 | ! |
checkmate::assert_class(data, "reactive") |
| 504 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 505 | ||
| 506 | ! |
moduleServer(id, function(input, output, session) {
|
| 507 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 508 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 509 | ! |
data_extract = list( |
| 510 | ! |
arm_var = arm_var, |
| 511 | ! |
id_var = id_var, |
| 512 | ! |
by_vars = by_vars, |
| 513 | ! |
grade = grade, |
| 514 | ! |
baseline_var = baseline_var, |
| 515 | ! |
treatment_flag_var = treatment_flag_var |
| 516 |
), |
|
| 517 | ! |
datasets = data, |
| 518 | ! |
select_validation_rule = list( |
| 519 | ! |
arm_var = shinyvalidate::sv_required( |
| 520 | ! |
"Please select a treatment variable." |
| 521 |
), |
|
| 522 | ! |
by_vars = shinyvalidate::sv_required( |
| 523 | ! |
"Please select a Row By Variable." |
| 524 |
), |
|
| 525 | ! |
id_var = shinyvalidate::sv_required( |
| 526 | ! |
"Please select a subject identifier." |
| 527 |
), |
|
| 528 | ! |
grade = shinyvalidate::sv_required( |
| 529 | ! |
"Please select a grade variable." |
| 530 |
), |
|
| 531 | ! |
baseline_var = shinyvalidate::sv_required( |
| 532 | ! |
"Please select a baseline grade variable." |
| 533 |
), |
|
| 534 | ! |
treatment_flag_var = shinyvalidate::sv_required( |
| 535 | ! |
"Please select indicator value for on treatment records." |
| 536 |
) |
|
| 537 |
) |
|
| 538 |
) |
|
| 539 | ||
| 540 | ! |
isolate({
|
| 541 | ! |
resolved <- teal.transform::resolve_delayed(treatment_flag, as.list(data()@env)) |
| 542 | ! |
teal.widgets::updateOptionalSelectInput( |
| 543 | ! |
session = session, |
| 544 | ! |
inputId = "treatment_flag", |
| 545 | ! |
choices = resolved$choices, |
| 546 | ! |
selected = resolved$selected |
| 547 |
) |
|
| 548 |
}) |
|
| 549 | ||
| 550 | ! |
iv_r <- reactive({
|
| 551 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 552 | ! |
iv$add_rule("treatment_flag", shinyvalidate::sv_required(
|
| 553 | ! |
"Please select indicator value for on treatment records." |
| 554 |
)) |
|
| 555 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 556 |
}) |
|
| 557 | ||
| 558 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 559 | ! |
datasets = data, |
| 560 | ! |
selector_list = selector_list, |
| 561 | ! |
merge_function = "dplyr::inner_join" |
| 562 |
) |
|
| 563 | ||
| 564 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 565 | ! |
datasets = data, |
| 566 | ! |
data_extract = list(arm_var = arm_var), |
| 567 | ! |
anl_name = "ANL_ADSL" |
| 568 |
) |
|
| 569 | ||
| 570 | ! |
anl_q <- reactive({
|
| 571 | ! |
data() %>% |
| 572 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 573 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 574 |
}) |
|
| 575 | ||
| 576 | ! |
merged <- list( |
| 577 | ! |
anl_input_r = anl_inputs, |
| 578 | ! |
adsl_input_r = adsl_inputs, |
| 579 | ! |
anl_q = anl_q |
| 580 |
) |
|
| 581 | ||
| 582 | ! |
validate_checks <- reactive({
|
| 583 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 584 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 585 | ||
| 586 | ! |
teal::validate_inputs(iv_r()) |
| 587 | ||
| 588 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 589 | ! |
input_id_var <- names(merged$anl_input_r()$columns_source$id_var) |
| 590 | ! |
input_by_vars <- names(merged$anl_input_r()$columns_source$by_vars) |
| 591 | ! |
input_grade <- names(merged$anl_input_r()$columns_source$grade) |
| 592 | ! |
input_baseline_var <- names(merged$anl_input_r()$columns_source$baseline_var) |
| 593 | ! |
input_treatment_flag_var <- names(merged$anl_input_r()$columns_source$treatment_flag_var) |
| 594 | ||
| 595 |
# validate inputs |
|
| 596 | ! |
validate_standard_inputs( |
| 597 | ! |
adsl = adsl_filtered, |
| 598 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 599 | ! |
anl = anl_filtered, |
| 600 | ! |
anlvars = c("USUBJID", "STUDYID", input_id_var, input_by_vars, input_grade),
|
| 601 | ! |
arm_var = input_arm_var |
| 602 |
) |
|
| 603 |
}) |
|
| 604 | ||
| 605 | ! |
all_q <- reactive({
|
| 606 | ! |
validate_checks() |
| 607 | ||
| 608 | ! |
by_vars_names <- merged$anl_input_r()$columns_source$by_vars |
| 609 | ! |
by_vars_labels <- as.character(sapply(by_vars_names, function(name) {
|
| 610 | ! |
attr(merged$anl_q()[["ANL"]][[name]], "label") |
| 611 |
})) |
|
| 612 | ||
| 613 | ! |
tbl_title <- ifelse( |
| 614 | ! |
length(by_vars_labels) == 1, |
| 615 | ! |
paste("Laboratory Abnormality summary by", by_vars_labels),
|
| 616 | ! |
paste(paste("Laboratory Abnormality summary by", paste(by_vars_labels, collapse = ", ")))
|
| 617 |
) |
|
| 618 | ||
| 619 | ! |
my_calls <- template_abnormality( |
| 620 | ! |
parentname = "ANL_ADSL", |
| 621 | ! |
dataname = "ANL", |
| 622 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 623 | ! |
by_vars = merged$anl_input_r()$columns_source$by_vars, |
| 624 | ! |
id_var = as.vector(merged$anl_input_r()$columns_source$id_var), |
| 625 | ! |
abnormal = abnormal, |
| 626 | ! |
grade = as.vector(merged$anl_input_r()$columns_source$grade), |
| 627 | ! |
baseline_var = as.vector(merged$anl_input_r()$columns_source$baseline_var), |
| 628 | ! |
treatment_flag_var = as.vector(merged$anl_input_r()$columns_source$treatment_flag_var), |
| 629 | ! |
treatment_flag = input$treatment_flag, |
| 630 | ! |
add_total = input$add_total, |
| 631 | ! |
total_label = total_label, |
| 632 | ! |
exclude_base_abn = input$exclude_base_abn, |
| 633 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 634 | ! |
na_level = na_level, |
| 635 | ! |
basic_table_args = basic_table_args, |
| 636 | ! |
tbl_title = tbl_title |
| 637 |
) |
|
| 638 | ||
| 639 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 640 |
}) |
|
| 641 | ||
| 642 |
# Outputs to render. |
|
| 643 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 644 | ||
| 645 | ! |
teal.widgets::table_with_settings_srv( |
| 646 | ! |
id = "table", |
| 647 | ! |
table_r = table_r |
| 648 |
) |
|
| 649 | ||
| 650 |
# Render R code. |
|
| 651 | ! |
teal.widgets::verbatim_popup_srv( |
| 652 | ! |
id = "rcode", |
| 653 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 654 | ! |
title = label |
| 655 |
) |
|
| 656 | ||
| 657 |
### REPORTER |
|
| 658 | ! |
if (with_reporter) {
|
| 659 | ! |
card_fun <- function(comment, label) {
|
| 660 | ! |
card <- teal::report_card_template( |
| 661 | ! |
title = "Abnormality Summary Table", |
| 662 | ! |
label = label, |
| 663 | ! |
with_filter = with_filter, |
| 664 | ! |
filter_panel_api = filter_panel_api |
| 665 |
) |
|
| 666 | ! |
card$append_text("Table", "header3")
|
| 667 | ! |
card$append_table(table_r()) |
| 668 | ! |
if (!comment == "") {
|
| 669 | ! |
card$append_text("Comment", "header3")
|
| 670 | ! |
card$append_text(comment) |
| 671 |
} |
|
| 672 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 673 | ! |
card |
| 674 |
} |
|
| 675 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 676 |
} |
|
| 677 |
### |
|
| 678 |
}) |
|
| 679 |
} |
| 1 |
#' Template: Survival Forest Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a survival forest plot. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @inheritParams template_forest_rsp |
|
| 7 |
#' @param stats (`character`)\cr the names of statistics to be reported among: |
|
| 8 |
#' * `n_tot_events`: Total number of events per group. |
|
| 9 |
#' * `n_events`: Number of events per group. |
|
| 10 |
#' * `n_tot`: Total number of observations per group. |
|
| 11 |
#' * `n`: Number of observations per group. |
|
| 12 |
#' * `median`: Median survival time. |
|
| 13 |
#' * `hr`: Hazard ratio. |
|
| 14 |
#' * `ci`: Confidence interval of hazard ratio. |
|
| 15 |
#' * `pval`: p-value of the effect. |
|
| 16 |
#' Note, one of the statistics `n_tot` and `n_tot_events`, as well as both `hr` and `ci` |
|
| 17 |
#' are required. |
|
| 18 |
#' |
|
| 19 |
#' @inherit template_arguments return |
|
| 20 |
#' |
|
| 21 |
#' @seealso [tm_g_forest_tte()] |
|
| 22 |
#' |
|
| 23 |
#' @keywords internal |
|
| 24 |
template_forest_tte <- function(dataname = "ANL", |
|
| 25 |
parentname = "ANL_ADSL", |
|
| 26 |
arm_var, |
|
| 27 |
ref_arm = NULL, |
|
| 28 |
comp_arm = NULL, |
|
| 29 |
obj_var_name = "", |
|
| 30 |
aval_var = "AVAL", |
|
| 31 |
cnsr_var = "CNSR", |
|
| 32 |
subgroup_var, |
|
| 33 |
strata_var = NULL, |
|
| 34 |
stats = c("n_tot_events", "n_events", "median", "hr", "ci"),
|
|
| 35 |
riskdiff = NULL, |
|
| 36 |
conf_level = 0.95, |
|
| 37 |
col_symbol_size = NULL, |
|
| 38 |
time_unit_var = "AVALU", |
|
| 39 |
rel_width_forest = 0.25, |
|
| 40 |
font_size = 15, |
|
| 41 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 42 | 2x |
checkmate::assert_string(dataname) |
| 43 | 2x |
checkmate::assert_string(arm_var) |
| 44 | 2x |
checkmate::assert_string(obj_var_name) |
| 45 | 2x |
checkmate::assert_character(subgroup_var, null.ok = TRUE) |
| 46 | 2x |
checkmate::assert_character(stats, min.len = 3) |
| 47 | 2x |
checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% stats))
|
| 48 | 2x |
checkmate::assert_true(all(c("hr", "ci") %in% stats))
|
| 49 | 2x |
checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 50 | 2x |
checkmate::assert_number(rel_width_forest, lower = 0, upper = 1) |
| 51 | 2x |
checkmate::assert_number(font_size) |
| 52 | ||
| 53 | 2x |
y <- list() |
| 54 | 2x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 55 | ||
| 56 |
# Data processing. |
|
| 57 | 2x |
data_list <- list() |
| 58 | 2x |
anl_list <- list() |
| 59 | 2x |
parent_list <- list() |
| 60 | ||
| 61 | 2x |
anl_list <- add_expr( |
| 62 | 2x |
anl_list, |
| 63 | 2x |
prepare_arm( |
| 64 | 2x |
dataname = dataname, |
| 65 | 2x |
arm_var = arm_var, |
| 66 | 2x |
ref_arm = ref_arm, |
| 67 | 2x |
comp_arm = comp_arm, |
| 68 | 2x |
ref_arm_val = ref_arm_val |
| 69 |
) |
|
| 70 |
) |
|
| 71 | ||
| 72 | 2x |
anl_list <- add_expr( |
| 73 | 2x |
anl_list, |
| 74 | 2x |
substitute_names( |
| 75 | 2x |
expr = {
|
| 76 | ! |
dplyr::mutate(arm_var = combine_levels(arm_var, comp_arm)) %>% |
| 77 | ! |
dplyr::mutate(is_event = cnsr_var == 0) |
| 78 |
}, |
|
| 79 | 2x |
names = list(arm_var = as.name(arm_var)), |
| 80 | 2x |
others = list( |
| 81 | 2x |
comp_arm = comp_arm, |
| 82 | 2x |
cnsr_var = as.name(cnsr_var) |
| 83 |
) |
|
| 84 |
) |
|
| 85 |
) |
|
| 86 | ||
| 87 | 2x |
data_list <- add_expr( |
| 88 | 2x |
data_list, |
| 89 | 2x |
substitute( |
| 90 | 2x |
anl <- anl_list, |
| 91 | 2x |
env = list( |
| 92 | 2x |
anl_list = pipe_expr(anl_list) |
| 93 |
) |
|
| 94 |
) |
|
| 95 |
) |
|
| 96 | ||
| 97 | 2x |
parent_list <- add_expr( |
| 98 | 2x |
parent_list, |
| 99 | 2x |
prepare_arm( |
| 100 | 2x |
dataname = parentname, |
| 101 | 2x |
arm_var = arm_var, |
| 102 | 2x |
ref_arm = ref_arm, |
| 103 | 2x |
comp_arm = comp_arm, |
| 104 | 2x |
ref_arm_val = ref_arm_val |
| 105 |
) |
|
| 106 |
) |
|
| 107 | ||
| 108 | 2x |
parent_list <- add_expr( |
| 109 | 2x |
parent_list, |
| 110 | 2x |
substitute_names( |
| 111 | 2x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, comp_arm)), |
| 112 | 2x |
names = list(arm_var = as.name(arm_var)), |
| 113 | 2x |
others = list( |
| 114 | 2x |
ref_arm = ref_arm, |
| 115 | 2x |
comp_arm = comp_arm |
| 116 |
) |
|
| 117 |
) |
|
| 118 |
) |
|
| 119 | ||
| 120 | 2x |
data_list <- add_expr( |
| 121 | 2x |
data_list, |
| 122 | 2x |
substitute( |
| 123 | 2x |
parent <- parent_list, |
| 124 | 2x |
env = list( |
| 125 | 2x |
parent_list = pipe_expr(parent_list) |
| 126 |
) |
|
| 127 |
) |
|
| 128 |
) |
|
| 129 | ||
| 130 | 2x |
y$data <- bracket_expr(data_list) |
| 131 | ||
| 132 |
# Tabulate subgroup analysis of response. |
|
| 133 | 2x |
summary_list <- list() |
| 134 | ||
| 135 | 2x |
summary_list <- add_expr( |
| 136 | 2x |
summary_list, |
| 137 | 2x |
substitute( |
| 138 | 2x |
expr = df <- extract_survival_subgroups( |
| 139 | 2x |
variables = list( |
| 140 | 2x |
tte = aval_var, |
| 141 | 2x |
is_event = "is_event", |
| 142 | 2x |
arm = arm_var, |
| 143 | 2x |
subgroups = subgroup_var, |
| 144 | 2x |
strata = strata_var |
| 145 |
), |
|
| 146 | 2x |
control = control_coxph(conf_level = conf_level), |
| 147 | 2x |
data = anl |
| 148 |
), |
|
| 149 | 2x |
env = list( |
| 150 | 2x |
aval_var = aval_var, |
| 151 | 2x |
arm_var = arm_var, |
| 152 | 2x |
subgroup_var = subgroup_var, |
| 153 | 2x |
strata_var = strata_var, |
| 154 | 2x |
conf_level = conf_level |
| 155 |
) |
|
| 156 |
) |
|
| 157 |
) |
|
| 158 | ||
| 159 | 2x |
y$summary <- bracket_expr(summary_list) |
| 160 | ||
| 161 |
# Table output. |
|
| 162 | 2x |
y$table <- substitute( |
| 163 | 2x |
expr = {
|
| 164 | ! |
result <- rtables::basic_table() %>% |
| 165 | ! |
tabulate_survival_subgroups( |
| 166 | ! |
df, |
| 167 | ! |
vars = stats, |
| 168 | ! |
time_unit = as.character(anl$time_unit_var[1]), |
| 169 | ! |
riskdiff = riskdiff |
| 170 |
) |
|
| 171 |
}, |
|
| 172 | 2x |
env = list(stats = stats, time_unit_var = as.name(time_unit_var), riskdiff = riskdiff) |
| 173 |
) |
|
| 174 | ||
| 175 | 2x |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 176 | 2x |
user_plot = ggplot2_args, |
| 177 | 2x |
module_plot = teal.widgets::ggplot2_args( |
| 178 | 2x |
labs = list( |
| 179 | 2x |
title = paste( |
| 180 | 2x |
paste("Forest Plot of Survival Duration for", obj_var_name),
|
| 181 | 2x |
ifelse(is.null(strata_var), "", paste("Stratified by", paste(strata_var, collapse = " and "))),
|
| 182 | 2x |
sep = "\n" |
| 183 |
), |
|
| 184 | 2x |
caption = "" |
| 185 |
) |
|
| 186 |
) |
|
| 187 |
) |
|
| 188 | ||
| 189 | 2x |
plot_list <- list() |
| 190 | ||
| 191 | 2x |
plot_list <- add_expr( |
| 192 | 2x |
plot_list, |
| 193 | 2x |
substitute( |
| 194 | 2x |
expr = {
|
| 195 | ! |
f <- g_forest( |
| 196 | ! |
tbl = result, |
| 197 | ! |
col_symbol_size = col_s_size, |
| 198 | ! |
font_size = font_size, |
| 199 | ! |
as_list = TRUE |
| 200 |
) |
|
| 201 |
}, |
|
| 202 | 2x |
env = list( |
| 203 | 2x |
col_s_size = col_symbol_size, |
| 204 | 2x |
font_size = font_size |
| 205 |
) |
|
| 206 |
) |
|
| 207 |
) |
|
| 208 | ||
| 209 | 2x |
plot_list <- add_expr( |
| 210 | 2x |
plot_list, |
| 211 | 2x |
substitute( |
| 212 | 2x |
expr = {
|
| 213 | ! |
p <- cowplot::plot_grid( |
| 214 | ! |
f[["table"]] + ggplot2::labs(title = ggplot2_args_title, subtitle = ggplot2_args_subtitle), |
| 215 | ! |
f[["plot"]] + ggplot2::labs(caption = ggplot2_args_caption), |
| 216 | ! |
align = "h", |
| 217 | ! |
axis = "tblr", |
| 218 | ! |
rel_widths = c(1 - rel_width_forest, rel_width_forest) |
| 219 |
) |
|
| 220 |
}, |
|
| 221 | 2x |
env = list( |
| 222 | 2x |
rel_width_forest = rel_width_forest, |
| 223 | 2x |
ggplot2_args_title = all_ggplot2_args$labs$title, |
| 224 | 2x |
ggplot2_args_subtitle = all_ggplot2_args$labs$subtitle, |
| 225 | 2x |
ggplot2_args_caption = all_ggplot2_args$labs$caption |
| 226 |
) |
|
| 227 |
) |
|
| 228 |
) |
|
| 229 | ||
| 230 |
# Plot output. |
|
| 231 | 2x |
y$plot <- plot_list |
| 232 | ||
| 233 | 2x |
y |
| 234 |
} |
|
| 235 | ||
| 236 |
#' teal Module: Forest Survival Plot |
|
| 237 |
#' |
|
| 238 |
#' This module produces a grid-style forest plot for time-to-event data with ADaM structure. |
|
| 239 |
#' |
|
| 240 |
#' @inheritParams tern::g_forest |
|
| 241 |
#' @inheritParams module_arguments |
|
| 242 |
#' @inheritParams template_forest_tte |
|
| 243 |
#' |
|
| 244 |
#' @inherit module_arguments return seealso |
|
| 245 |
#' |
|
| 246 |
#' @examples |
|
| 247 |
#' library(nestcolor) |
|
| 248 |
#' |
|
| 249 |
#' ADSL <- tmc_ex_adsl |
|
| 250 |
#' ADTTE <- tmc_ex_adtte |
|
| 251 |
#' ADSL$RACE <- droplevels(ADSL$RACE) %>% with_label("Race")
|
|
| 252 |
#' |
|
| 253 |
#' arm_ref_comp <- list( |
|
| 254 |
#' ARM = list( |
|
| 255 |
#' ref = "B: Placebo", |
|
| 256 |
#' comp = c("A: Drug X", "C: Combination")
|
|
| 257 |
#' ), |
|
| 258 |
#' ARMCD = list( |
|
| 259 |
#' ref = "ARM B", |
|
| 260 |
#' comp = c("ARM A", "ARM C")
|
|
| 261 |
#' ) |
|
| 262 |
#' ) |
|
| 263 |
#' |
|
| 264 |
#' app <- init( |
|
| 265 |
#' data = cdisc_data( |
|
| 266 |
#' ADSL = ADSL, |
|
| 267 |
#' ADTTE = ADTTE, |
|
| 268 |
#' code = " |
|
| 269 |
#' ADSL <- tmc_ex_adsl |
|
| 270 |
#' ADTTE <- tmc_ex_adtte |
|
| 271 |
#' ADSL$RACE <- droplevels(ADSL$RACE) %>% with_label(\"Race\") |
|
| 272 |
#' " |
|
| 273 |
#' ), |
|
| 274 |
#' modules = modules( |
|
| 275 |
#' tm_g_forest_tte( |
|
| 276 |
#' label = "Forest Survival", |
|
| 277 |
#' dataname = "ADTTE", |
|
| 278 |
#' arm_var = choices_selected( |
|
| 279 |
#' variable_choices(ADSL, c("ARM", "ARMCD")),
|
|
| 280 |
#' "ARMCD" |
|
| 281 |
#' ), |
|
| 282 |
#' arm_ref_comp = arm_ref_comp, |
|
| 283 |
#' paramcd = choices_selected( |
|
| 284 |
#' value_choices(ADTTE, "PARAMCD", "PARAM"), |
|
| 285 |
#' "OS" |
|
| 286 |
#' ), |
|
| 287 |
#' subgroup_var = choices_selected( |
|
| 288 |
#' variable_choices(ADSL, names(ADSL)), |
|
| 289 |
#' c("BMRKR2", "SEX")
|
|
| 290 |
#' ), |
|
| 291 |
#' strata_var = choices_selected( |
|
| 292 |
#' variable_choices(ADSL, c("STRATA1", "STRATA2")),
|
|
| 293 |
#' "STRATA2" |
|
| 294 |
#' ) |
|
| 295 |
#' ) |
|
| 296 |
#' ) |
|
| 297 |
#' ) |
|
| 298 |
#' if (interactive()) {
|
|
| 299 |
#' shinyApp(app$ui, app$server) |
|
| 300 |
#' } |
|
| 301 |
#' |
|
| 302 |
#' @export |
|
| 303 |
tm_g_forest_tte <- function(label, |
|
| 304 |
dataname, |
|
| 305 |
parentname = ifelse( |
|
| 306 |
inherits(arm_var, "data_extract_spec"), |
|
| 307 |
teal.transform::datanames_input(arm_var), |
|
| 308 |
"ADSL" |
|
| 309 |
), |
|
| 310 |
arm_var, |
|
| 311 |
arm_ref_comp = NULL, |
|
| 312 |
subgroup_var, |
|
| 313 |
paramcd, |
|
| 314 |
strata_var, |
|
| 315 |
aval_var = teal.transform::choices_selected( |
|
| 316 |
teal.transform::variable_choices(dataname, "AVAL"), "AVAL", |
|
| 317 |
fixed = TRUE |
|
| 318 |
), |
|
| 319 |
cnsr_var = teal.transform::choices_selected( |
|
| 320 |
teal.transform::variable_choices(dataname, "CNSR"), "CNSR", |
|
| 321 |
fixed = TRUE |
|
| 322 |
), |
|
| 323 |
stats = c("n_tot_events", "n_events", "median", "hr", "ci"),
|
|
| 324 |
riskdiff = NULL, |
|
| 325 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 326 |
time_unit_var = teal.transform::choices_selected( |
|
| 327 |
teal.transform::variable_choices(dataname, "AVALU"), "AVALU", |
|
| 328 |
fixed = TRUE |
|
| 329 |
), |
|
| 330 |
fixed_symbol_size = TRUE, |
|
| 331 |
plot_height = c(500L, 200L, 2000L), |
|
| 332 |
plot_width = c(1500L, 800L, 3000L), |
|
| 333 |
rel_width_forest = c(25L, 0L, 100L), |
|
| 334 |
font_size = c(15L, 1L, 30L), |
|
| 335 |
pre_output = NULL, |
|
| 336 |
post_output = NULL, |
|
| 337 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 338 | ! |
message("Initializing tm_g_forest_tte")
|
| 339 | ! |
checkmate::assert_string(label) |
| 340 | ! |
checkmate::assert_string(dataname) |
| 341 | ! |
checkmate::assert_string(parentname) |
| 342 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 343 | ! |
checkmate::assert_class(subgroup_var, "choices_selected") |
| 344 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 345 | ! |
checkmate::assert_class(strata_var, "choices_selected") |
| 346 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 347 | ! |
checkmate::assert_class(cnsr_var, "choices_selected") |
| 348 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 349 | ! |
checkmate::assert_class(time_unit_var, "choices_selected") |
| 350 | ! |
checkmate::assert_character(stats, min.len = 3) |
| 351 | ! |
checkmate::assert_true(any(c("n_tot", "n_tot_events") %in% stats))
|
| 352 | ! |
checkmate::assert_true(all(c("hr", "ci") %in% stats))
|
| 353 | ! |
checkmate::assert_list(riskdiff, null.ok = TRUE) |
| 354 | ! |
checkmate::assert_flag(fixed_symbol_size) |
| 355 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 356 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 357 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 358 | ! |
checkmate::assert_numeric( |
| 359 | ! |
plot_width[1], |
| 360 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 361 |
) |
|
| 362 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 363 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 364 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 365 | ||
| 366 | ! |
args <- as.list(environment()) |
| 367 | ||
| 368 | ! |
data_extract_list <- list( |
| 369 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 370 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 371 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 372 | ! |
cnsr_var = cs_to_des_select(cnsr_var, dataname = dataname), |
| 373 | ! |
subgroup_var = cs_to_des_select(subgroup_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 374 | ! |
strata_var = cs_to_des_select(strata_var, dataname = parentname, multiple = TRUE), |
| 375 | ! |
time_unit_var = cs_to_des_select(time_unit_var, dataname = dataname) |
| 376 |
) |
|
| 377 | ||
| 378 | ! |
module( |
| 379 | ! |
label = label, |
| 380 | ! |
server = srv_g_forest_tte, |
| 381 | ! |
ui = ui_g_forest_tte, |
| 382 | ! |
ui_args = c(data_extract_list, args), |
| 383 | ! |
server_args = c( |
| 384 | ! |
data_extract_list, |
| 385 | ! |
list( |
| 386 | ! |
dataname = dataname, |
| 387 | ! |
arm_ref_comp = arm_ref_comp, |
| 388 | ! |
parentname = parentname, |
| 389 | ! |
stats = stats, |
| 390 | ! |
riskdiff = riskdiff, |
| 391 | ! |
plot_height = plot_height, |
| 392 | ! |
plot_width = plot_width, |
| 393 | ! |
ggplot2_args = ggplot2_args |
| 394 |
) |
|
| 395 |
), |
|
| 396 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 397 |
) |
|
| 398 |
} |
|
| 399 | ||
| 400 |
#' @keywords internal |
|
| 401 |
ui_g_forest_tte <- function(id, ...) {
|
|
| 402 | ! |
a <- list(...) |
| 403 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 404 | ! |
a$arm_var, |
| 405 | ! |
a$paramcd, |
| 406 | ! |
a$subgroup_var, |
| 407 | ! |
a$strata_var, |
| 408 | ! |
a$aval_var, |
| 409 | ! |
a$cnsr_var, |
| 410 | ! |
a$time_unit_var |
| 411 |
) |
|
| 412 | ||
| 413 | ! |
ns <- NS(id) |
| 414 | ||
| 415 | ! |
teal.widgets::standard_layout( |
| 416 | ! |
output = teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 417 | ! |
encoding = tags$div( |
| 418 |
### Reporter |
|
| 419 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 420 |
### |
|
| 421 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 422 | ! |
teal.transform::datanames_input(a[c("arm_var", "paramcd", "subgroup_var", "strata_var", "aval_var", "cnsr_var")]),
|
| 423 | ! |
teal.transform::data_extract_ui( |
| 424 | ! |
id = ns("paramcd"),
|
| 425 | ! |
label = "Select Endpoint", |
| 426 | ! |
data_extract_spec = a$paramcd, |
| 427 | ! |
is_single_dataset = is_single_dataset_value |
| 428 |
), |
|
| 429 | ! |
teal.transform::data_extract_ui( |
| 430 | ! |
id = ns("aval_var"),
|
| 431 | ! |
label = "Analysis Variable", |
| 432 | ! |
data_extract_spec = a$aval_var, |
| 433 | ! |
is_single_dataset = is_single_dataset_value |
| 434 |
), |
|
| 435 | ! |
teal.transform::data_extract_ui( |
| 436 | ! |
id = ns("cnsr_var"),
|
| 437 | ! |
label = "Censor Variable", |
| 438 | ! |
data_extract_spec = a$cnsr_var, |
| 439 | ! |
is_single_dataset = is_single_dataset_value |
| 440 |
), |
|
| 441 | ! |
teal.transform::data_extract_ui( |
| 442 | ! |
id = ns("arm_var"),
|
| 443 | ! |
label = "Select Treatment Variable", |
| 444 | ! |
data_extract_spec = a$arm_var, |
| 445 | ! |
is_single_dataset = is_single_dataset_value |
| 446 |
), |
|
| 447 | ! |
uiOutput( |
| 448 | ! |
ns("arms_buckets"),
|
| 449 | ! |
title = paste( |
| 450 | ! |
"Multiple reference groups are automatically combined into a single group when more than one", |
| 451 | ! |
"value is selected." |
| 452 |
) |
|
| 453 |
), |
|
| 454 | ! |
teal.transform::data_extract_ui( |
| 455 | ! |
id = ns("subgroup_var"),
|
| 456 | ! |
label = "Subgroup Variables", |
| 457 | ! |
data_extract_spec = a$subgroup_var, |
| 458 | ! |
is_single_dataset = is_single_dataset_value |
| 459 |
), |
|
| 460 | ! |
teal.transform::data_extract_ui( |
| 461 | ! |
id = ns("strata_var"),
|
| 462 | ! |
label = "Stratify by", |
| 463 | ! |
data_extract_spec = a$strata_var, |
| 464 | ! |
is_single_dataset = is_single_dataset_value |
| 465 |
), |
|
| 466 | ! |
teal.widgets::panel_group( |
| 467 | ! |
teal.widgets::panel_item( |
| 468 | ! |
"Additional plot settings", |
| 469 | ! |
teal.widgets::optionalSelectInput( |
| 470 | ! |
ns("conf_level"),
|
| 471 | ! |
"Level of Confidence", |
| 472 | ! |
a$conf_level$choices, |
| 473 | ! |
a$conf_level$selected, |
| 474 | ! |
multiple = FALSE, |
| 475 | ! |
fixed = a$conf_level$fixed |
| 476 |
), |
|
| 477 | ! |
checkboxInput(ns("fixed_symbol_size"), "Fixed symbol size", value = TRUE),
|
| 478 | ! |
teal.transform::data_extract_ui( |
| 479 | ! |
id = ns("time_unit_var"),
|
| 480 | ! |
label = "Time Unit Variable", |
| 481 | ! |
data_extract_spec = a$time_unit_var, |
| 482 | ! |
is_single_dataset = is_single_dataset_value |
| 483 |
), |
|
| 484 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 485 | ! |
ns("rel_width_forest"),
|
| 486 | ! |
"Relative Width of Forest Plot (%)", |
| 487 | ! |
a$rel_width_forest, |
| 488 | ! |
ticks = FALSE, step = 1 |
| 489 |
), |
|
| 490 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 491 | ! |
ns("font_size"),
|
| 492 | ! |
"Table Font Size", |
| 493 | ! |
a$font_size, |
| 494 | ! |
ticks = FALSE, step = 1 |
| 495 |
) |
|
| 496 |
) |
|
| 497 |
) |
|
| 498 |
), |
|
| 499 | ! |
forms = tagList( |
| 500 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 501 |
), |
|
| 502 | ! |
pre_output = a$pre_output, |
| 503 | ! |
post_output = a$post_output |
| 504 |
) |
|
| 505 |
} |
|
| 506 | ||
| 507 |
#' @keywords internal |
|
| 508 |
srv_g_forest_tte <- function(id, |
|
| 509 |
data, |
|
| 510 |
reporter, |
|
| 511 |
filter_panel_api, |
|
| 512 |
dataname, |
|
| 513 |
parentname, |
|
| 514 |
arm_var, |
|
| 515 |
arm_ref_comp, |
|
| 516 |
paramcd, |
|
| 517 |
subgroup_var, |
|
| 518 |
strata_var, |
|
| 519 |
aval_var, |
|
| 520 |
cnsr_var, |
|
| 521 |
time_unit_var, |
|
| 522 |
stats, |
|
| 523 |
riskdiff, |
|
| 524 |
plot_height, |
|
| 525 |
plot_width, |
|
| 526 |
ggplot2_args) {
|
|
| 527 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 528 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 529 | ! |
checkmate::assert_class(data, "reactive") |
| 530 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 531 | ||
| 532 | ! |
moduleServer(id, function(input, output, session) {
|
| 533 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 534 |
# Setup arm variable selection, default reference arms, and default |
|
| 535 |
# comparison arms for encoding panel |
|
| 536 | ! |
iv_arm_ref <- arm_ref_comp_observer( |
| 537 | ! |
session, |
| 538 | ! |
input, |
| 539 | ! |
output, |
| 540 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 541 | ! |
data = data()[[parentname]], |
| 542 | ! |
arm_ref_comp = arm_ref_comp, |
| 543 | ! |
module = "tm_g_forest_tte" |
| 544 |
) |
|
| 545 | ||
| 546 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 547 | ! |
data_extract = list( |
| 548 | ! |
arm_var = arm_var, |
| 549 | ! |
paramcd = paramcd, |
| 550 | ! |
subgroup_var = subgroup_var, |
| 551 | ! |
strata_var = strata_var, |
| 552 | ! |
aval_var = aval_var, |
| 553 | ! |
cnsr_var = cnsr_var, |
| 554 | ! |
time_unit_var = time_unit_var |
| 555 |
), |
|
| 556 | ! |
datasets = data, |
| 557 | ! |
select_validation_rule = list( |
| 558 | ! |
aval_var = shinyvalidate::sv_required("An analysis variable is required"),
|
| 559 | ! |
cnsr_var = shinyvalidate::sv_required("A censor variable is required"),
|
| 560 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required")
|
| 561 |
), |
|
| 562 | ! |
filter_validation_rule = list(paramcd = shinyvalidate::sv_required(message = "Please select Endpoint filter.")) |
| 563 |
) |
|
| 564 | ||
| 565 | ! |
iv_r <- reactive({
|
| 566 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 567 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level"))
|
| 568 | ! |
iv$add_rule( |
| 569 | ! |
"conf_level", |
| 570 | ! |
shinyvalidate::sv_between(0, 1, message_fmt = "Confidence level must be between 0 and 1") |
| 571 |
) |
|
| 572 | ! |
iv$add_validator(iv_arm_ref) |
| 573 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 574 |
}) |
|
| 575 | ||
| 576 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 577 | ! |
datasets = data, |
| 578 | ! |
selector_list = selector_list, |
| 579 | ! |
merge_function = "dplyr::inner_join" |
| 580 |
) |
|
| 581 | ||
| 582 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 583 | ! |
datasets = data, |
| 584 | ! |
data_extract = list(arm_var = arm_var, subgroup_var = subgroup_var, strata_var = strata_var), |
| 585 | ! |
anl_name = "ANL_ADSL" |
| 586 |
) |
|
| 587 | ||
| 588 | ! |
anl_q <- reactive({
|
| 589 | ! |
data() %>% |
| 590 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 591 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 592 |
}) |
|
| 593 | ||
| 594 | ! |
validate_checks <- reactive({
|
| 595 | ! |
teal::validate_inputs(iv_r()) |
| 596 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 597 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 598 | ! |
anl <- anl_q()[["ANL"]] |
| 599 | ||
| 600 | ! |
anl_m <- anl_inputs() |
| 601 | ! |
input_arm_var <- as.vector(anl_m$columns_source$arm_var) |
| 602 | ! |
input_aval_var <- as.vector(anl_m$columns_source$aval_var) |
| 603 | ! |
input_cnsr_var <- as.vector(anl_m$columns_source$cnsr_var) |
| 604 | ! |
input_subgroup_var <- as.vector(anl_m$columns_source$subgroup_var) |
| 605 | ! |
input_strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 606 | ! |
input_time_unit_var <- as.vector(anl_m$columns_source$time_unit_var) |
| 607 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 608 | ||
| 609 |
# validate inputs |
|
| 610 | ! |
validate_args <- list( |
| 611 | ! |
adsl = adsl_filtered, |
| 612 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var, input_subgroup_var, input_strata_var),
|
| 613 | ! |
anl = anl_filtered, |
| 614 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_aval_var, input_cnsr_var, input_time_unit_var),
|
| 615 | ! |
arm_var = input_arm_var |
| 616 |
) |
|
| 617 | ||
| 618 |
# validate arm levels |
|
| 619 | ! |
if (length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) == 1) {
|
| 620 | ! |
validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) |
| 621 |
} |
|
| 622 | ! |
validate_args <- append( |
| 623 | ! |
validate_args, list(ref_arm = unlist(input$buckets$Ref), comp_arm = unlist(input$buckets$Comp)) |
| 624 |
) |
|
| 625 | ||
| 626 | ! |
if (length(input_subgroup_var) > 0) {
|
| 627 | ! |
validate( |
| 628 | ! |
need( |
| 629 | ! |
all(vapply(adsl_filtered[, input_subgroup_var], is.factor, logical(1))), |
| 630 | ! |
"Not all subgroup variables are factors." |
| 631 |
) |
|
| 632 |
) |
|
| 633 |
} |
|
| 634 | ||
| 635 | ! |
if (length(input_strata_var) > 0) {
|
| 636 | ! |
validate( |
| 637 | ! |
need( |
| 638 | ! |
all(vapply(adsl_filtered[, input_strata_var], is.factor, logical(1))), |
| 639 | ! |
"Not all stratification variables are factors." |
| 640 |
) |
|
| 641 |
) |
|
| 642 |
} |
|
| 643 | ||
| 644 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 645 | ||
| 646 | ! |
validate(need( |
| 647 | ! |
length(anl[[input_paramcd]]) > 0, |
| 648 | ! |
"Value of the endpoint variable should not be empty." |
| 649 |
)) |
|
| 650 | ||
| 651 | ! |
NULL |
| 652 |
}) |
|
| 653 | ||
| 654 |
# The R-code corresponding to the analysis. |
|
| 655 | ! |
all_q <- reactive({
|
| 656 | ! |
validate_checks() |
| 657 | ||
| 658 | ! |
anl_m <- anl_inputs() |
| 659 | ||
| 660 | ! |
strata_var <- as.vector(anl_m$columns_source$strata_var) |
| 661 | ! |
subgroup_var <- as.vector(anl_m$columns_source$subgroup_var) |
| 662 | ||
| 663 | ! |
obj_var_name <- get_g_forest_obj_var_name(paramcd, input) |
| 664 | ||
| 665 | ! |
my_calls <- template_forest_tte( |
| 666 | ! |
dataname = "ANL", |
| 667 | ! |
parentname = "ANL_ADSL", |
| 668 | ! |
arm_var = as.vector(anl_m$columns_source$arm_var), |
| 669 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 670 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 671 | ! |
obj_var_name = obj_var_name, |
| 672 | ! |
aval_var = as.vector(anl_m$columns_source$aval_var), |
| 673 | ! |
cnsr_var = as.vector(anl_m$columns_source$cnsr_var), |
| 674 | ! |
subgroup_var = if (length(subgroup_var) != 0) subgroup_var else NULL, |
| 675 | ! |
strata_var = if (length(strata_var) != 0) strata_var else NULL, |
| 676 | ! |
stats = stats, |
| 677 | ! |
riskdiff = riskdiff, |
| 678 | ! |
conf_level = as.numeric(input$conf_level), |
| 679 | ! |
col_symbol_size = if (!input$fixed_symbol_size) 1, |
| 680 | ! |
time_unit_var = as.vector(anl_m$columns_source$time_unit_var), |
| 681 | ! |
rel_width_forest = input$rel_width_forest / 100, |
| 682 | ! |
font_size = input$font_size, |
| 683 | ! |
ggplot2_args = ggplot2_args |
| 684 |
) |
|
| 685 | ! |
teal.code::eval_code(anl_q(), as.expression(my_calls)) |
| 686 |
}) |
|
| 687 | ||
| 688 |
# Outputs to render. |
|
| 689 | ! |
plot_r <- reactive(all_q()[["p"]]) |
| 690 | ||
| 691 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 692 | ! |
id = "myplot", |
| 693 | ! |
plot_r = plot_r, |
| 694 | ! |
height = plot_height, |
| 695 | ! |
width = plot_width |
| 696 |
) |
|
| 697 | ||
| 698 | ! |
teal.widgets::verbatim_popup_srv( |
| 699 | ! |
id = "rcode", |
| 700 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 701 | ! |
title = "R Code for the Current Time-to-Event Forest Plot" |
| 702 |
) |
|
| 703 | ||
| 704 |
### REPORTER |
|
| 705 | ! |
if (with_reporter) {
|
| 706 | ! |
card_fun <- function(comment, label) {
|
| 707 | ! |
card <- teal::report_card_template( |
| 708 | ! |
title = "Forest Survival Plot", |
| 709 | ! |
label = label, |
| 710 | ! |
with_filter = with_filter, |
| 711 | ! |
filter_panel_api = filter_panel_api |
| 712 |
) |
|
| 713 | ! |
card$append_text("Plot", "header3")
|
| 714 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 715 | ! |
if (!comment == "") {
|
| 716 | ! |
card$append_text("Comment", "header3")
|
| 717 | ! |
card$append_text(comment) |
| 718 |
} |
|
| 719 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 720 | ! |
card |
| 721 |
} |
|
| 722 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 723 |
} |
|
| 724 |
### |
|
| 725 |
}) |
|
| 726 |
} |
| 1 |
#' Template: Patient Profile Medical History |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a patient profile medical history report using ADaM datasets. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param mhterm (`character`)\cr name of the reported term for the medical history variable. |
|
| 7 |
#' @param mhbodsys (`character`)\cr name of the body system or organ class variable. |
|
| 8 |
#' @param mhdistat (`character`)\cr name of the status of the disease variable. |
|
| 9 |
#' |
|
| 10 |
#' @inherit template_arguments return |
|
| 11 |
#' |
|
| 12 |
#' @seealso [tm_t_pp_medical_history()] |
|
| 13 |
#' |
|
| 14 |
#' @keywords internal |
|
| 15 |
template_medical_history <- function(dataname = "ANL", |
|
| 16 |
mhterm = "MHTERM", |
|
| 17 |
mhbodsys = "MHBODSYS", |
|
| 18 |
mhdistat = "MHDISTAT", |
|
| 19 |
patient_id = NULL) {
|
|
| 20 | 3x |
checkmate::assert_string(dataname) |
| 21 | 3x |
checkmate::assert_string(mhterm) |
| 22 | 3x |
checkmate::assert_string(mhbodsys) |
| 23 | 3x |
checkmate::assert_string(mhdistat) |
| 24 | ||
| 25 | 3x |
y <- list() |
| 26 | 3x |
y$table <- list() |
| 27 | ||
| 28 | 3x |
table_list <- add_expr( |
| 29 | 3x |
list(), |
| 30 | 3x |
substitute(expr = {
|
| 31 | ! |
labels <- teal.data::col_labels(dataname, fill = FALSE)[c(mhbodsys_char, mhterm_char, mhdistat_char)] |
| 32 | ! |
mhbodsys_label <- labels[mhbodsys_char] |
| 33 | ||
| 34 | ! |
result_raw <- |
| 35 | ! |
dataname %>% |
| 36 | ! |
dplyr::select(mhbodsys, mhterm, mhdistat) %>% |
| 37 | ! |
dplyr::arrange(mhbodsys) %>% |
| 38 | ! |
dplyr::mutate_if(is.character, as.factor) %>% |
| 39 | ! |
dplyr::mutate_if(is.factor, function(x) explicit_na(x, "UNKNOWN")) %>% |
| 40 | ! |
dplyr::distinct() %>% |
| 41 | ! |
`colnames<-`(labels) |
| 42 | ||
| 43 | ! |
result <- rtables::basic_table() %>% |
| 44 | ! |
rtables::split_cols_by_multivar(colnames(result_raw)[2:3]) %>% |
| 45 | ! |
rtables::split_rows_by( |
| 46 | ! |
colnames(result_raw)[1], |
| 47 | ! |
split_fun = rtables::drop_split_levels |
| 48 |
) %>% |
|
| 49 | ! |
rtables::split_rows_by( |
| 50 | ! |
colnames(result_raw)[2], |
| 51 | ! |
split_fun = rtables::drop_split_levels, |
| 52 | ! |
child_labels = "hidden" |
| 53 |
) %>% |
|
| 54 | ! |
rtables::analyze_colvars(function(x) x[seq_along(x)]) %>% |
| 55 | ! |
rtables::build_table(result_raw) |
| 56 | ||
| 57 | ! |
main_title(result) <- paste("Patient ID:", patient_id)
|
| 58 | ||
| 59 | ! |
result |
| 60 | 3x |
}, env = list( |
| 61 | 3x |
dataname = as.name(dataname), |
| 62 | 3x |
mhbodsys = as.name(mhbodsys), |
| 63 | 3x |
mhterm = as.name(mhterm), |
| 64 | 3x |
mhdistat = as.name(mhdistat), |
| 65 | 3x |
mhbodsys_char = mhbodsys, |
| 66 | 3x |
mhterm_char = mhterm, |
| 67 | 3x |
mhdistat_char = mhdistat, |
| 68 | 3x |
patient_id = patient_id |
| 69 |
)) |
|
| 70 |
) |
|
| 71 | ||
| 72 | 3x |
y$table <- bracket_expr(table_list) |
| 73 | ||
| 74 | 3x |
y |
| 75 |
} |
|
| 76 | ||
| 77 |
#' teal Module: Patient Profile Medical History |
|
| 78 |
#' |
|
| 79 |
#' This module produces a patient profile medical history report using ADaM datasets. |
|
| 80 |
#' |
|
| 81 |
#' @inheritParams module_arguments |
|
| 82 |
#' @inheritParams template_medical_history |
|
| 83 |
#' @param mhterm ([teal.transform::choices_selected()])\cr object with all |
|
| 84 |
#' available choices and preselected option for the `MHTERM` variable from `dataname`. |
|
| 85 |
#' @param mhbodsys ([teal.transform::choices_selected()])\cr object with all |
|
| 86 |
#' available choices and preselected option for the `MHBODSYS` variable from `dataname`. |
|
| 87 |
#' @param mhdistat ([teal.transform::choices_selected()])\cr object with all |
|
| 88 |
#' available choices and preselected option for the `MHDISTAT` variable from `dataname`. |
|
| 89 |
#' |
|
| 90 |
#' @inherit module_arguments return |
|
| 91 |
#' |
|
| 92 |
#' @examples |
|
| 93 |
#' ADSL <- tmc_ex_adsl |
|
| 94 |
#' ADMH <- tmc_ex_admh |
|
| 95 |
#' |
|
| 96 |
#' app <- init( |
|
| 97 |
#' data = cdisc_data( |
|
| 98 |
#' ADSL = ADSL, |
|
| 99 |
#' ADMH = ADMH, |
|
| 100 |
#' code = " |
|
| 101 |
#' ADSL <- tmc_ex_adsl |
|
| 102 |
#' ADMH <- tmc_ex_admh |
|
| 103 |
#' " |
|
| 104 |
#' ), |
|
| 105 |
#' modules = modules( |
|
| 106 |
#' tm_t_pp_medical_history( |
|
| 107 |
#' label = "Medical History", |
|
| 108 |
#' dataname = "ADMH", |
|
| 109 |
#' parentname = "ADSL", |
|
| 110 |
#' patient_col = "USUBJID", |
|
| 111 |
#' mhterm = choices_selected( |
|
| 112 |
#' choices = variable_choices(ADMH, c("MHTERM")),
|
|
| 113 |
#' selected = "MHTERM" |
|
| 114 |
#' ), |
|
| 115 |
#' mhbodsys = choices_selected( |
|
| 116 |
#' choices = variable_choices(ADMH, "MHBODSYS"), |
|
| 117 |
#' selected = "MHBODSYS" |
|
| 118 |
#' ), |
|
| 119 |
#' mhdistat = choices_selected( |
|
| 120 |
#' choices = variable_choices(ADMH, "MHDISTAT"), |
|
| 121 |
#' selected = "MHDISTAT" |
|
| 122 |
#' ) |
|
| 123 |
#' ) |
|
| 124 |
#' ) |
|
| 125 |
#' ) |
|
| 126 |
#' if (interactive()) {
|
|
| 127 |
#' shinyApp(app$ui, app$server) |
|
| 128 |
#' } |
|
| 129 |
#' |
|
| 130 |
#' @export |
|
| 131 |
tm_t_pp_medical_history <- function(label, |
|
| 132 |
dataname = "ADMH", |
|
| 133 |
parentname = "ADSL", |
|
| 134 |
patient_col = "USUBJID", |
|
| 135 |
mhterm = NULL, |
|
| 136 |
mhbodsys = NULL, |
|
| 137 |
mhdistat = NULL, |
|
| 138 |
pre_output = NULL, |
|
| 139 |
post_output = NULL) {
|
|
| 140 | ! |
message("Initializing tm_t_pp_medical_history")
|
| 141 | ! |
checkmate::assert_string(label) |
| 142 | ! |
checkmate::assert_string(dataname) |
| 143 | ! |
checkmate::assert_string(parentname) |
| 144 | ! |
checkmate::assert_string(patient_col) |
| 145 | ! |
checkmate::assert_class(mhterm, "choices_selected", null.ok = TRUE) |
| 146 | ! |
checkmate::assert_class(mhbodsys, "choices_selected", null.ok = TRUE) |
| 147 | ! |
checkmate::assert_class(mhdistat, "choices_selected", null.ok = TRUE) |
| 148 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 149 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 150 | ||
| 151 | ! |
args <- as.list(environment()) |
| 152 | ! |
data_extract_list <- list( |
| 153 | ! |
mhterm = `if`(is.null(mhterm), NULL, cs_to_des_select(mhterm, dataname = dataname)), |
| 154 | ! |
mhbodsys = `if`(is.null(mhbodsys), NULL, cs_to_des_select(mhbodsys, dataname = dataname)), |
| 155 | ! |
mhdistat = `if`(is.null(mhdistat), NULL, cs_to_des_select(mhdistat, dataname = dataname)) |
| 156 |
) |
|
| 157 | ||
| 158 | ! |
module( |
| 159 | ! |
label = label, |
| 160 | ! |
ui = ui_t_medical_history, |
| 161 | ! |
ui_args = c(data_extract_list, args), |
| 162 | ! |
server = srv_t_medical_history, |
| 163 | ! |
server_args = c( |
| 164 | ! |
data_extract_list, |
| 165 | ! |
list( |
| 166 | ! |
dataname = dataname, |
| 167 | ! |
parentname = parentname, |
| 168 | ! |
label = label, |
| 169 | ! |
patient_col = patient_col |
| 170 |
) |
|
| 171 |
), |
|
| 172 | ! |
datanames = c(dataname, parentname) |
| 173 |
) |
|
| 174 |
} |
|
| 175 | ||
| 176 |
#' @keywords internal |
|
| 177 |
ui_t_medical_history <- function(id, ...) {
|
|
| 178 | ! |
ui_args <- list(...) |
| 179 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 180 | ! |
ui_args$mhterm, |
| 181 | ! |
ui_args$mhbodsys, |
| 182 | ! |
ui_args$mhdistat |
| 183 |
) |
|
| 184 | ||
| 185 | ! |
ns <- NS(id) |
| 186 | ! |
teal.widgets::standard_layout( |
| 187 | ! |
output = tags$div( |
| 188 | ! |
teal.widgets::table_with_settings_ui(ns("table"))
|
| 189 |
), |
|
| 190 | ! |
encoding = tags$div( |
| 191 |
### Reporter |
|
| 192 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 193 |
### |
|
| 194 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 195 | ! |
teal.transform::datanames_input(ui_args[c("mhterm", "mhbodsys", "mhdistat")]),
|
| 196 | ! |
teal.widgets::optionalSelectInput( |
| 197 | ! |
ns("patient_id"),
|
| 198 | ! |
"Select Patient:", |
| 199 | ! |
multiple = FALSE, |
| 200 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 201 |
), |
|
| 202 | ! |
teal.transform::data_extract_ui( |
| 203 | ! |
id = ns("mhterm"),
|
| 204 | ! |
label = "Select MHTERM variable:", |
| 205 | ! |
data_extract_spec = ui_args$mhterm, |
| 206 | ! |
is_single_dataset = is_single_dataset_value |
| 207 |
), |
|
| 208 | ! |
teal.transform::data_extract_ui( |
| 209 | ! |
id = ns("mhbodsys"),
|
| 210 | ! |
label = "Select MHBODSYS variable:", |
| 211 | ! |
data_extract_spec = ui_args$mhbodsys, |
| 212 | ! |
is_single_dataset = is_single_dataset_value |
| 213 |
), |
|
| 214 | ! |
teal.transform::data_extract_ui( |
| 215 | ! |
id = ns("mhdistat"),
|
| 216 | ! |
label = "Select MHDISTAT variable:", |
| 217 | ! |
data_extract_spec = ui_args$mhdistat, |
| 218 | ! |
is_single_dataset = is_single_dataset_value |
| 219 |
) |
|
| 220 |
), |
|
| 221 | ! |
forms = tagList( |
| 222 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 223 |
), |
|
| 224 | ! |
pre_output = ui_args$pre_output, |
| 225 | ! |
post_output = ui_args$post_output |
| 226 |
) |
|
| 227 |
} |
|
| 228 | ||
| 229 |
#' @keywords internal |
|
| 230 |
srv_t_medical_history <- function(id, |
|
| 231 |
data, |
|
| 232 |
reporter, |
|
| 233 |
filter_panel_api, |
|
| 234 |
dataname, |
|
| 235 |
parentname, |
|
| 236 |
patient_col, |
|
| 237 |
mhterm, |
|
| 238 |
mhbodsys, |
|
| 239 |
mhdistat, |
|
| 240 |
label) {
|
|
| 241 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 242 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 243 | ! |
checkmate::assert_class(data, "reactive") |
| 244 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 245 | ||
| 246 | ! |
moduleServer(id, function(input, output, session) {
|
| 247 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 248 | ! |
patient_id <- reactive(input$patient_id) |
| 249 | ||
| 250 |
# Init |
|
| 251 | ! |
patient_data_base <- reactive(unique(data()[[parentname]][[patient_col]])) |
| 252 | ! |
teal.widgets::updateOptionalSelectInput( |
| 253 | ! |
session, "patient_id", |
| 254 | ! |
choices = patient_data_base(), selected = patient_data_base()[1] |
| 255 |
) |
|
| 256 | ||
| 257 | ! |
observeEvent(patient_data_base(), |
| 258 | ! |
handlerExpr = {
|
| 259 | ! |
teal.widgets::updateOptionalSelectInput( |
| 260 | ! |
session, |
| 261 | ! |
"patient_id", |
| 262 | ! |
choices = patient_data_base(), |
| 263 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 264 | ! |
patient_data_base() |
| 265 |
} else {
|
|
| 266 | ! |
intersect(patient_id(), patient_data_base()) |
| 267 |
} |
|
| 268 |
) |
|
| 269 |
}, |
|
| 270 | ! |
ignoreInit = TRUE |
| 271 |
) |
|
| 272 | ||
| 273 |
# Medical history tab ---- |
|
| 274 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 275 | ! |
data_extract = list(mhterm = mhterm, mhbodsys = mhbodsys, mhdistat = mhdistat), |
| 276 | ! |
datasets = data, |
| 277 | ! |
select_validation_rule = list( |
| 278 | ! |
mhterm = shinyvalidate::sv_required("Please select MHTERM variable."),
|
| 279 | ! |
mhbodsys = shinyvalidate::sv_required("Please select MHBODSYS variable."),
|
| 280 | ! |
mhdistat = shinyvalidate::sv_required("Please select MHDISTAT variable.")
|
| 281 |
) |
|
| 282 |
) |
|
| 283 | ||
| 284 | ! |
iv_r <- reactive({
|
| 285 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 286 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient"))
|
| 287 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 288 |
}) |
|
| 289 | ||
| 290 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 291 | ! |
datasets = data, |
| 292 | ! |
selector_list = selector_list, |
| 293 | ! |
merge_function = "dplyr::left_join" |
| 294 |
) |
|
| 295 | ||
| 296 | ! |
anl_q <- reactive({
|
| 297 | ! |
data() %>% |
| 298 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 299 |
}) |
|
| 300 | ||
| 301 | ! |
all_q <- reactive({
|
| 302 | ! |
teal::validate_inputs(iv_r()) |
| 303 | ||
| 304 | ! |
validate( |
| 305 | ! |
need( |
| 306 | ! |
nrow(anl_q()[["ANL"]][anl_q()[["ANL"]][[patient_col]] == patient_id(), ]) > 0, |
| 307 | ! |
"Patient has no data about medical history." |
| 308 |
) |
|
| 309 |
) |
|
| 310 | ||
| 311 | ! |
my_calls <- template_medical_history( |
| 312 | ! |
dataname = "ANL", |
| 313 | ! |
mhterm = input[[extract_input("mhterm", dataname)]],
|
| 314 | ! |
mhbodsys = input[[extract_input("mhbodsys", dataname)]],
|
| 315 | ! |
mhdistat = input[[extract_input("mhdistat", dataname)]],
|
| 316 | ! |
patient_id = patient_id() |
| 317 |
) |
|
| 318 | ||
| 319 | ! |
teal.code::eval_code( |
| 320 | ! |
anl_q(), |
| 321 | ! |
substitute( |
| 322 | ! |
expr = {
|
| 323 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 324 | ! |
}, env = list( |
| 325 | ! |
patient_col = patient_col, |
| 326 | ! |
patient_id = patient_id() |
| 327 |
) |
|
| 328 |
) |
|
| 329 |
) %>% |
|
| 330 | ! |
teal.code::eval_code(as.expression(my_calls)) |
| 331 |
}) |
|
| 332 | ||
| 333 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 334 | ||
| 335 | ! |
teal.widgets::table_with_settings_srv( |
| 336 | ! |
id = "table", |
| 337 | ! |
table_r = table_r |
| 338 |
) |
|
| 339 | ||
| 340 | ! |
teal.widgets::verbatim_popup_srv( |
| 341 | ! |
id = "rcode", |
| 342 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 343 | ! |
title = label |
| 344 |
) |
|
| 345 | ||
| 346 |
### REPORTER |
|
| 347 | ! |
if (with_reporter) {
|
| 348 | ! |
card_fun <- function(comment, label) {
|
| 349 | ! |
card <- teal::report_card_template( |
| 350 | ! |
title = "Patient Medical History Table", |
| 351 | ! |
label = label, |
| 352 | ! |
with_filter = with_filter, |
| 353 | ! |
filter_panel_api = filter_panel_api |
| 354 |
) |
|
| 355 | ! |
card$append_text("Table", "header3")
|
| 356 | ! |
card$append_table(table_r()) |
| 357 | ! |
if (!comment == "") {
|
| 358 | ! |
card$append_text("Comment", "header3")
|
| 359 | ! |
card$append_text(comment) |
| 360 |
} |
|
| 361 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 362 | ! |
card |
| 363 |
} |
|
| 364 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 365 |
} |
|
| 366 |
### |
|
| 367 |
}) |
|
| 368 |
} |
| 1 |
#' Template: Patient Profile Prior Medication |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a patient profile prior medication report using ADaM datasets. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' |
|
| 7 |
#' @inherit template_arguments return |
|
| 8 |
#' |
|
| 9 |
#' @seealso [tm_t_pp_prior_medication()] |
|
| 10 |
#' |
|
| 11 |
#' @keywords internal |
|
| 12 |
template_prior_medication <- function(dataname = "ANL", |
|
| 13 |
atirel = "ATIREL", |
|
| 14 |
cmdecod = "CMDECOD", |
|
| 15 |
cmindc = "CMINDC", |
|
| 16 |
cmstdy = "CMSTDY") {
|
|
| 17 | ! |
checkmate::assert_string(dataname) |
| 18 | ! |
checkmate::assert_string(atirel) |
| 19 | ! |
checkmate::assert_string(cmdecod) |
| 20 | ! |
checkmate::assert_string(cmindc) |
| 21 | ! |
checkmate::assert_string(cmstdy) |
| 22 | ||
| 23 | ! |
y <- list() |
| 24 | ! |
y$table <- list() |
| 25 | ||
| 26 | ! |
table_list <- add_expr( |
| 27 | ! |
list(), |
| 28 | ! |
substitute(expr = {
|
| 29 | ! |
result <- |
| 30 | ! |
dataname %>% |
| 31 | ! |
dplyr::filter(atirel %in% c("PRIOR", "PRIOR_CONCOMITANT")) %>%
|
| 32 | ! |
dplyr::select(cmindc, cmdecod, cmstdy) %>% |
| 33 | ! |
dplyr::filter(!is.na(cmdecod)) %>% |
| 34 | ! |
dplyr::distinct() %>% |
| 35 | ! |
`colnames<-`(col_labels(dataname, fill = TRUE)[c(cmindc_char, cmdecod_char, cmstdy_char)]) |
| 36 | ! |
result |
| 37 | ! |
}, env = list( |
| 38 | ! |
dataname = as.name(dataname), |
| 39 | ! |
atirel = as.name(atirel), |
| 40 | ! |
cmdecod = as.name(cmdecod), |
| 41 | ! |
cmindc = as.name(cmindc), |
| 42 | ! |
cmstdy = as.name(cmstdy), |
| 43 | ! |
atirel_char = atirel, |
| 44 | ! |
cmdecod_char = cmdecod, |
| 45 | ! |
cmindc_char = cmindc, |
| 46 | ! |
cmstdy_char = cmstdy |
| 47 |
)) |
|
| 48 |
) |
|
| 49 |
# Note: l_html_concomitant_adcm is still not included since one column is available out of 9 |
|
| 50 | ||
| 51 | ! |
y$table <- bracket_expr(table_list) |
| 52 | ! |
y |
| 53 |
} |
|
| 54 | ||
| 55 |
#' teal Module: Patient Profile Prior Medication |
|
| 56 |
#' |
|
| 57 |
#' This module produces a patient profile prior medication report using ADaM datasets. |
|
| 58 |
#' |
|
| 59 |
#' @inheritParams module_arguments |
|
| 60 |
#' @inheritParams template_prior_medication |
|
| 61 |
#' |
|
| 62 |
#' @inherit module_arguments return |
|
| 63 |
#' |
|
| 64 |
#' @examples |
|
| 65 |
#' library(dplyr) |
|
| 66 |
#' |
|
| 67 |
#' ADCM <- tmc_ex_adcm |
|
| 68 |
#' ADSL <- tmc_ex_adsl %>% filter(USUBJID %in% ADCM$USUBJID) |
|
| 69 |
#' ADCM$CMASTDTM <- ADCM$ASTDTM |
|
| 70 |
#' ADCM$CMAENDTM <- ADCM$AENDTM |
|
| 71 |
#' adcm_keys <- c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "ATC1", "ATC2", "ATC3", "ATC4")
|
|
| 72 |
#' |
|
| 73 |
#' join_keys <- default_cdisc_join_keys[c("ADSL", "ADCM")]
|
|
| 74 |
#' join_keys["ADCM", "ADCM"] <- adcm_keys |
|
| 75 |
#' |
|
| 76 |
#' app <- init( |
|
| 77 |
#' data = cdisc_data( |
|
| 78 |
#' ADSL = ADSL, |
|
| 79 |
#' ADCM = ADCM, |
|
| 80 |
#' code = " |
|
| 81 |
#' ADCM <- tmc_ex_adcm |
|
| 82 |
#' ADSL <- tmc_ex_adsl %>% filter(USUBJID %in% ADCM$USUBJID) |
|
| 83 |
#' ADCM$CMASTDTM <- ADCM$ASTDTM |
|
| 84 |
#' ADCM$CMAENDTM <- ADCM$AENDTM |
|
| 85 |
#' ", |
|
| 86 |
#' join_keys = join_keys |
|
| 87 |
#' ), |
|
| 88 |
#' modules = modules( |
|
| 89 |
#' tm_t_pp_prior_medication( |
|
| 90 |
#' label = "Prior Medication", |
|
| 91 |
#' dataname = "ADCM", |
|
| 92 |
#' parentname = "ADSL", |
|
| 93 |
#' patient_col = "USUBJID", |
|
| 94 |
#' atirel = choices_selected( |
|
| 95 |
#' choices = variable_choices(ADCM, "ATIREL"), |
|
| 96 |
#' selected = "ATIREL" |
|
| 97 |
#' ), |
|
| 98 |
#' cmdecod = choices_selected( |
|
| 99 |
#' choices = variable_choices(ADCM, "CMDECOD"), |
|
| 100 |
#' selected = "CMDECOD" |
|
| 101 |
#' ), |
|
| 102 |
#' cmindc = choices_selected( |
|
| 103 |
#' choices = variable_choices(ADCM, "CMINDC"), |
|
| 104 |
#' selected = "CMINDC" |
|
| 105 |
#' ), |
|
| 106 |
#' cmstdy = choices_selected( |
|
| 107 |
#' choices = variable_choices(ADCM, "ASTDY"), |
|
| 108 |
#' selected = "ASTDY" |
|
| 109 |
#' ) |
|
| 110 |
#' ) |
|
| 111 |
#' ) |
|
| 112 |
#' ) |
|
| 113 |
#' if (interactive()) {
|
|
| 114 |
#' shinyApp(app$ui, app$server) |
|
| 115 |
#' } |
|
| 116 |
#' |
|
| 117 |
#' @export |
|
| 118 |
tm_t_pp_prior_medication <- function(label, |
|
| 119 |
dataname = "ADCM", |
|
| 120 |
parentname = "ADSL", |
|
| 121 |
patient_col = "USUBJID", |
|
| 122 |
atirel = NULL, |
|
| 123 |
cmdecod = NULL, |
|
| 124 |
cmindc = NULL, |
|
| 125 |
cmstdy = NULL, |
|
| 126 |
pre_output = NULL, |
|
| 127 |
post_output = NULL) {
|
|
| 128 | ! |
message("Initializing tm_t_pp_prior_medication")
|
| 129 | ! |
checkmate::assert_string(label) |
| 130 | ! |
checkmate::assert_string(dataname) |
| 131 | ! |
checkmate::assert_string(parentname) |
| 132 | ! |
checkmate::assert_string(patient_col) |
| 133 | ! |
checkmate::assert_class(atirel, "choices_selected", null.ok = TRUE) |
| 134 | ! |
checkmate::assert_class(cmdecod, "choices_selected", null.ok = TRUE) |
| 135 | ! |
checkmate::assert_class(cmindc, "choices_selected", null.ok = TRUE) |
| 136 | ! |
checkmate::assert_class(cmstdy, "choices_selected", null.ok = TRUE) |
| 137 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 138 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 139 | ||
| 140 | ! |
args <- as.list(environment()) |
| 141 | ! |
data_extract_list <- list( |
| 142 | ! |
atirel = `if`(is.null(atirel), NULL, cs_to_des_select(atirel, dataname = dataname)), |
| 143 | ! |
cmdecod = `if`(is.null(cmdecod), NULL, cs_to_des_select(cmdecod, dataname = dataname)), |
| 144 | ! |
cmindc = `if`(is.null(cmindc), NULL, cs_to_des_select(cmindc, dataname = dataname)), |
| 145 | ! |
cmstdy = `if`(is.null(cmstdy), NULL, cs_to_des_select(cmstdy, dataname = dataname)) |
| 146 |
) |
|
| 147 | ||
| 148 | ! |
module( |
| 149 | ! |
label = label, |
| 150 | ! |
ui = ui_t_prior_medication, |
| 151 | ! |
ui_args = c(data_extract_list, args), |
| 152 | ! |
server = srv_t_prior_medication, |
| 153 | ! |
server_args = c( |
| 154 | ! |
data_extract_list, |
| 155 | ! |
list( |
| 156 | ! |
dataname = dataname, |
| 157 | ! |
parentname = parentname, |
| 158 | ! |
label = label, |
| 159 | ! |
patient_col = patient_col |
| 160 |
) |
|
| 161 |
), |
|
| 162 | ! |
datanames = c(dataname, parentname) |
| 163 |
) |
|
| 164 |
} |
|
| 165 | ||
| 166 |
#' @keywords internal |
|
| 167 |
ui_t_prior_medication <- function(id, ...) {
|
|
| 168 | ! |
ui_args <- list(...) |
| 169 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 170 | ! |
ui_args$atirel, |
| 171 | ! |
ui_args$cmdecod, |
| 172 | ! |
ui_args$cmindc, |
| 173 | ! |
ui_args$cmstdy |
| 174 |
) |
|
| 175 | ||
| 176 | ! |
ns <- NS(id) |
| 177 | ! |
teal.widgets::standard_layout( |
| 178 | ! |
output = tags$div( |
| 179 | ! |
DT::DTOutput(outputId = ns("prior_medication_table"))
|
| 180 |
), |
|
| 181 | ! |
encoding = tags$div( |
| 182 |
### Reporter |
|
| 183 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 184 |
### |
|
| 185 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 186 | ! |
teal.transform::datanames_input(ui_args[c("atirel", "cmdecod", "cmindc", "cmstdy")]),
|
| 187 | ! |
teal.widgets::optionalSelectInput( |
| 188 | ! |
ns("patient_id"),
|
| 189 | ! |
"Select Patient:", |
| 190 | ! |
multiple = FALSE, |
| 191 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 192 |
), |
|
| 193 | ! |
teal.transform::data_extract_ui( |
| 194 | ! |
id = ns("cmdecod"),
|
| 195 | ! |
label = "Select the medication decoding column:", |
| 196 | ! |
data_extract_spec = ui_args$cmdecod, |
| 197 | ! |
is_single_dataset = is_single_dataset_value |
| 198 |
), |
|
| 199 | ! |
teal.transform::data_extract_ui( |
| 200 | ! |
id = ns("atirel"),
|
| 201 | ! |
label = "Select ATIREL variable:", |
| 202 | ! |
data_extract_spec = ui_args$atirel, |
| 203 | ! |
is_single_dataset = is_single_dataset_value |
| 204 |
), |
|
| 205 | ! |
teal.transform::data_extract_ui( |
| 206 | ! |
id = ns("cmindc"),
|
| 207 | ! |
label = "Select CMINDC variable:", |
| 208 | ! |
data_extract_spec = ui_args$cmindc, |
| 209 | ! |
is_single_dataset = is_single_dataset_value |
| 210 |
), |
|
| 211 | ! |
teal.transform::data_extract_ui( |
| 212 | ! |
id = ns("cmstdy"),
|
| 213 | ! |
label = "Select CMSTDY variable:", |
| 214 | ! |
data_extract_spec = ui_args$cmstdy, |
| 215 | ! |
is_single_dataset = is_single_dataset_value |
| 216 |
) |
|
| 217 |
), |
|
| 218 | ! |
forms = tagList( |
| 219 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 220 |
), |
|
| 221 | ! |
pre_output = ui_args$pre_output, |
| 222 | ! |
post_output = ui_args$post_output |
| 223 |
) |
|
| 224 |
} |
|
| 225 | ||
| 226 |
#' @keywords internal |
|
| 227 |
srv_t_prior_medication <- function(id, |
|
| 228 |
data, |
|
| 229 |
reporter, |
|
| 230 |
filter_panel_api, |
|
| 231 |
dataname, |
|
| 232 |
parentname, |
|
| 233 |
patient_col, |
|
| 234 |
atirel, |
|
| 235 |
cmdecod, |
|
| 236 |
cmindc, |
|
| 237 |
cmstdy, |
|
| 238 |
label) {
|
|
| 239 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 240 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 241 | ! |
checkmate::assert_class(data, "reactive") |
| 242 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 243 | ||
| 244 | ! |
moduleServer(id, function(input, output, session) {
|
| 245 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 246 | ! |
patient_id <- reactive(input$patient_id) |
| 247 | ||
| 248 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 249 | ! |
data_extract = list( |
| 250 | ! |
atirel = atirel, |
| 251 | ! |
cmdecod = cmdecod, |
| 252 | ! |
cmindc = cmindc, |
| 253 | ! |
cmstdy = cmstdy |
| 254 |
), |
|
| 255 | ! |
datasets = data, |
| 256 | ! |
select_validation_rule = list( |
| 257 | ! |
atirel = shinyvalidate::sv_required("An ATIREL variable is required"),
|
| 258 | ! |
cmdecod = shinyvalidate::sv_required("A medication decoding variable is required"),
|
| 259 | ! |
cmindc = shinyvalidate::sv_required("A CMINDC variable is required"),
|
| 260 | ! |
cmstdy = shinyvalidate::sv_required("A CMSTDY variable is required")
|
| 261 |
) |
|
| 262 |
) |
|
| 263 | ||
| 264 | ! |
iv_r <- reactive({
|
| 265 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 266 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required("Please select patient id"))
|
| 267 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 268 |
}) |
|
| 269 | ||
| 270 |
# Init |
|
| 271 | ! |
patient_data_base <- reactive(unique(data()[[parentname]][[patient_col]])) |
| 272 | ! |
teal.widgets::updateOptionalSelectInput( |
| 273 | ! |
session, |
| 274 | ! |
"patient_id", |
| 275 | ! |
choices = patient_data_base(), |
| 276 | ! |
selected = patient_data_base()[1] |
| 277 |
) |
|
| 278 | ||
| 279 | ! |
observeEvent(patient_data_base(), |
| 280 | ! |
handlerExpr = {
|
| 281 | ! |
teal.widgets::updateOptionalSelectInput( |
| 282 | ! |
session, |
| 283 | ! |
"patient_id", |
| 284 | ! |
choices = patient_data_base(), |
| 285 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 286 | ! |
patient_data_base() |
| 287 |
} else {
|
|
| 288 | ! |
intersect(patient_id(), patient_data_base()) |
| 289 |
} |
|
| 290 |
) |
|
| 291 |
}, |
|
| 292 | ! |
ignoreInit = TRUE |
| 293 |
) |
|
| 294 | ||
| 295 |
# Prior medication tab ---- |
|
| 296 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 297 | ! |
datasets = data, |
| 298 | ! |
selector_list = selector_list, |
| 299 | ! |
merge_function = "dplyr::left_join" |
| 300 |
) |
|
| 301 | ||
| 302 | ! |
anl_q <- reactive({
|
| 303 | ! |
data() %>% |
| 304 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 305 |
}) |
|
| 306 | ||
| 307 | ! |
all_q <- reactive({
|
| 308 | ! |
teal::validate_inputs(iv_r()) |
| 309 | ||
| 310 | ! |
my_calls <- template_prior_medication( |
| 311 | ! |
dataname = "ANL", |
| 312 | ! |
atirel = input[[extract_input("atirel", dataname)]],
|
| 313 | ! |
cmdecod = input[[extract_input("cmdecod", dataname)]],
|
| 314 | ! |
cmindc = input[[extract_input("cmindc", dataname)]],
|
| 315 | ! |
cmstdy = input[[extract_input("cmstdy", dataname)]]
|
| 316 |
) |
|
| 317 | ||
| 318 | ! |
anl_q() %>% |
| 319 | ! |
teal.code::eval_code( |
| 320 | ! |
substitute( |
| 321 | ! |
expr = {
|
| 322 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 323 | ! |
}, env = list( |
| 324 | ! |
patient_col = patient_col, |
| 325 | ! |
patient_id = patient_id() |
| 326 |
) |
|
| 327 |
) |
|
| 328 |
) %>% |
|
| 329 | ! |
teal.code::eval_code(as.expression(my_calls)) |
| 330 |
}) |
|
| 331 | ||
| 332 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 333 | ||
| 334 | ! |
output$prior_medication_table <- DT::renderDataTable( |
| 335 | ! |
expr = table_r(), |
| 336 | ! |
options = list( |
| 337 | ! |
lengthMenu = list(list(-1, 5, 10, 25), list("All", "5", "10", "25"))
|
| 338 |
) |
|
| 339 |
) |
|
| 340 | ||
| 341 | ! |
teal.widgets::verbatim_popup_srv( |
| 342 | ! |
id = "rcode", |
| 343 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 344 | ! |
title = label |
| 345 |
) |
|
| 346 | ||
| 347 | ! |
if (with_reporter) {
|
| 348 | ! |
card_fun <- function(comment, label) {
|
| 349 | ! |
card <- teal::report_card_template( |
| 350 | ! |
title = "Patient Prior Medication Table", |
| 351 | ! |
label = label, |
| 352 | ! |
with_filter = with_filter, |
| 353 | ! |
filter_panel_api = filter_panel_api |
| 354 |
) |
|
| 355 | ! |
card$append_text("Table", "header3")
|
| 356 | ! |
card$append_table(table_r()) |
| 357 | ! |
if (!comment == "") {
|
| 358 | ! |
card$append_text("Comment", "header3")
|
| 359 | ! |
card$append_text(comment) |
| 360 |
} |
|
| 361 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 362 | ! |
card |
| 363 |
} |
|
| 364 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 365 |
} |
|
| 366 |
### |
|
| 367 |
}) |
|
| 368 |
} |
| 1 |
#' Template: Patient Profile Basic Info |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a patient profile basic info report using ADaM datasets. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param vars (`character`)\cr names of the variables to be shown in the table. |
|
| 7 |
#' |
|
| 8 |
#' @inherit template_arguments return |
|
| 9 |
#' |
|
| 10 |
#' @seealso [tm_t_pp_basic_info()] |
|
| 11 |
#' |
|
| 12 |
#' @keywords internal |
|
| 13 |
template_basic_info <- function(dataname = "ANL", |
|
| 14 |
vars, |
|
| 15 |
patient_id = NULL) {
|
|
| 16 | ! |
checkmate::assert_string(dataname) |
| 17 | ! |
checkmate::assert_character(vars, min.len = 1) |
| 18 | ||
| 19 | ! |
y <- list() |
| 20 | ! |
y$table <- list() |
| 21 | ||
| 22 | ! |
table_list <- add_expr( |
| 23 | ! |
list(), |
| 24 | ! |
substitute( |
| 25 | ! |
expr = {
|
| 26 | ! |
values <- dataname %>% |
| 27 | ! |
dplyr::select(vars) %>% |
| 28 |
# we are sure that only one row |
|
| 29 | ! |
utils::head(1) %>% |
| 30 | ! |
t() |
| 31 | ||
| 32 | ! |
key <- col_labels(dataname, fill = TRUE)[rownames(values)] |
| 33 | ||
| 34 | ! |
result <- |
| 35 | ! |
data.frame(var = rownames(values), key = key, value = values) %>% |
| 36 | ! |
dplyr::select(var, key, value) %>% |
| 37 | ! |
dplyr::rename(` ` = var, ` ` = key, ` ` = value) |
| 38 | ||
| 39 | ! |
result <- rlistings::as_listing( |
| 40 | ! |
result, |
| 41 | ! |
default_formatting = list(all = fmt_config(align = "left")) |
| 42 |
) |
|
| 43 | ! |
main_title(result) <- paste("Patient ID:", patient_id)
|
| 44 | ||
| 45 | ! |
result |
| 46 | ! |
}, env = list( |
| 47 | ! |
dataname = as.name(dataname), |
| 48 | ! |
vars = vars, |
| 49 | ! |
patient_id = patient_id |
| 50 |
) |
|
| 51 |
) |
|
| 52 |
) |
|
| 53 | ! |
y$table <- bracket_expr(table_list) |
| 54 | ||
| 55 | ! |
y |
| 56 |
} |
|
| 57 | ||
| 58 |
#' teal Module: Patient Profile Basic Info |
|
| 59 |
#' |
|
| 60 |
#' This module produces a patient profile basic info report using ADaM datasets. |
|
| 61 |
#' |
|
| 62 |
#' @inheritParams module_arguments |
|
| 63 |
#' @inheritParams template_basic_info |
|
| 64 |
#' @param vars ([teal.transform::choices_selected()])\cr object with all |
|
| 65 |
#' available choices and preselected option for variables from `dataname` to show in the table. |
|
| 66 |
#' |
|
| 67 |
#' @inherit module_arguments return |
|
| 68 |
#' |
|
| 69 |
#' @examples |
|
| 70 |
#' ADSL <- tmc_ex_adsl |
|
| 71 |
#' |
|
| 72 |
#' app <- init( |
|
| 73 |
#' data = cdisc_data( |
|
| 74 |
#' ADSL = ADSL, |
|
| 75 |
#' code = "ADSL <- tmc_ex_adsl" |
|
| 76 |
#' ), |
|
| 77 |
#' modules = modules( |
|
| 78 |
#' tm_t_pp_basic_info( |
|
| 79 |
#' label = "Basic Info", |
|
| 80 |
#' dataname = "ADSL", |
|
| 81 |
#' patient_col = "USUBJID", |
|
| 82 |
#' vars = choices_selected( |
|
| 83 |
#' choices = variable_choices(ADSL), |
|
| 84 |
#' selected = c("ARM", "AGE", "SEX", "COUNTRY", "RACE", "EOSSTT")
|
|
| 85 |
#' ) |
|
| 86 |
#' ) |
|
| 87 |
#' ) |
|
| 88 |
#' ) |
|
| 89 |
#' if (interactive()) {
|
|
| 90 |
#' shinyApp(app$ui, app$server) |
|
| 91 |
#' } |
|
| 92 |
#' |
|
| 93 |
#' @export |
|
| 94 |
tm_t_pp_basic_info <- function(label, |
|
| 95 |
dataname = "ADSL", |
|
| 96 |
patient_col = "USUBJID", |
|
| 97 |
vars = NULL, |
|
| 98 |
pre_output = NULL, |
|
| 99 |
post_output = NULL) {
|
|
| 100 | ! |
message("Initializing tm_t_pp_basic_info")
|
| 101 | ! |
checkmate::assert_string(label) |
| 102 | ! |
checkmate::assert_string(dataname) |
| 103 | ! |
checkmate::assert_string(patient_col) |
| 104 | ! |
checkmate::assert_class(vars, "choices_selected", null.ok = TRUE) |
| 105 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 106 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 107 | ||
| 108 | ! |
args <- as.list(environment()) |
| 109 | ! |
data_extract_list <- list( |
| 110 | ! |
vars = `if`(is.null(vars), NULL, cs_to_des_select(vars, dataname = dataname, multiple = TRUE)) |
| 111 |
) |
|
| 112 | ||
| 113 | ! |
module( |
| 114 | ! |
label = label, |
| 115 | ! |
ui = ui_t_basic_info, |
| 116 | ! |
ui_args = c(data_extract_list, args), |
| 117 | ! |
server = srv_t_basic_info, |
| 118 | ! |
server_args = c( |
| 119 | ! |
data_extract_list, |
| 120 | ! |
list( |
| 121 | ! |
dataname = dataname, |
| 122 | ! |
label = label, |
| 123 | ! |
patient_col = patient_col |
| 124 |
) |
|
| 125 |
), |
|
| 126 | ! |
datanames = dataname |
| 127 |
) |
|
| 128 |
} |
|
| 129 | ||
| 130 |
#' @keywords internal |
|
| 131 |
ui_t_basic_info <- function(id, ...) {
|
|
| 132 | ! |
ui_args <- list(...) |
| 133 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset(ui_args$vars) |
| 134 | ||
| 135 | ! |
ns <- NS(id) |
| 136 | ! |
teal.widgets::standard_layout( |
| 137 | ! |
output = tags$div( |
| 138 | ! |
htmlOutput(ns("title")),
|
| 139 | ! |
DT::DTOutput(outputId = ns("basic_info_table"))
|
| 140 |
), |
|
| 141 | ! |
encoding = tags$div( |
| 142 |
### Reporter |
|
| 143 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 144 |
### |
|
| 145 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 146 | ! |
teal.transform::datanames_input(ui_args[c("vars")]),
|
| 147 | ! |
teal.widgets::optionalSelectInput( |
| 148 | ! |
ns("patient_id"),
|
| 149 | ! |
"Select Patient:", |
| 150 | ! |
multiple = FALSE, |
| 151 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 152 |
), |
|
| 153 | ! |
teal.transform::data_extract_ui( |
| 154 | ! |
id = ns("vars"),
|
| 155 | ! |
label = "Select variable:", |
| 156 | ! |
data_extract_spec = ui_args$vars, |
| 157 | ! |
is_single_dataset = is_single_dataset_value |
| 158 |
) |
|
| 159 |
), |
|
| 160 | ! |
forms = tagList( |
| 161 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 162 |
), |
|
| 163 | ! |
pre_output = ui_args$pre_output, |
| 164 | ! |
post_output = ui_args$post_output |
| 165 |
) |
|
| 166 |
} |
|
| 167 | ||
| 168 |
#' @keywords internal |
|
| 169 |
srv_t_basic_info <- function(id, |
|
| 170 |
data, |
|
| 171 |
reporter, |
|
| 172 |
filter_panel_api, |
|
| 173 |
dataname, |
|
| 174 |
patient_col, |
|
| 175 |
vars, |
|
| 176 |
label) {
|
|
| 177 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 178 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 179 | ! |
checkmate::assert_class(data, "reactive") |
| 180 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 181 | ||
| 182 | ! |
moduleServer(id, function(input, output, session) {
|
| 183 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 184 | ! |
patient_id <- reactive(input$patient_id) |
| 185 | ||
| 186 |
# Init |
|
| 187 | ! |
patient_data_base <- reactive(unique(data()[[dataname]][[patient_col]])) |
| 188 | ! |
teal.widgets::updateOptionalSelectInput( |
| 189 | ! |
session, |
| 190 | ! |
"patient_id", |
| 191 | ! |
choices = patient_data_base(), |
| 192 | ! |
selected = patient_data_base()[1] |
| 193 |
) |
|
| 194 | ||
| 195 | ! |
observeEvent(patient_data_base(), |
| 196 | ! |
handlerExpr = {
|
| 197 | ! |
teal.widgets::updateOptionalSelectInput( |
| 198 | ! |
session, |
| 199 | ! |
"patient_id", |
| 200 | ! |
choices = patient_data_base(), |
| 201 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 202 | ! |
patient_data_base() |
| 203 |
} else {
|
|
| 204 | ! |
intersect(patient_id(), patient_data_base()) |
| 205 |
} |
|
| 206 |
) |
|
| 207 |
}, |
|
| 208 | ! |
ignoreInit = TRUE |
| 209 |
) |
|
| 210 | ||
| 211 |
# Basic Info tab ---- |
|
| 212 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 213 | ! |
data_extract = list(vars = vars), |
| 214 | ! |
datasets = data, |
| 215 | ! |
select_validation_rule = list( |
| 216 | ! |
vars = shinyvalidate::sv_required("Please select basic info variables")
|
| 217 |
) |
|
| 218 |
) |
|
| 219 | ||
| 220 | ! |
iv_r <- reactive({
|
| 221 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 222 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient"))
|
| 223 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 224 |
}) |
|
| 225 | ||
| 226 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 227 | ! |
datasets = data, |
| 228 | ! |
selector_list = selector_list, |
| 229 | ! |
merge_function = "dplyr::left_join" |
| 230 |
) |
|
| 231 | ||
| 232 | ! |
anl_q <- reactive({
|
| 233 | ! |
data() %>% |
| 234 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 235 |
}) |
|
| 236 | ||
| 237 | ! |
all_q <- reactive({
|
| 238 | ! |
teal::validate_inputs(iv_r()) |
| 239 | ! |
my_calls <- template_basic_info( |
| 240 | ! |
dataname = "ANL", |
| 241 | ! |
vars = anl_inputs()$columns_source$vars, |
| 242 | ! |
patient_id = patient_id() |
| 243 |
) |
|
| 244 | ||
| 245 | ! |
teal.code::eval_code( |
| 246 | ! |
anl_q(), |
| 247 | ! |
substitute( |
| 248 | ! |
expr = {
|
| 249 | ! |
pt_id <- patient_id |
| 250 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 251 | ! |
}, env = list( |
| 252 | ! |
patient_col = patient_col, |
| 253 | ! |
patient_id = patient_id() |
| 254 |
) |
|
| 255 |
) |
|
| 256 |
) %>% |
|
| 257 | ! |
teal.code::eval_code(as.expression(my_calls)) |
| 258 |
}) |
|
| 259 | ||
| 260 | ! |
output$title <- renderText({
|
| 261 | ! |
paste("<h5><b>Patient ID:", all_q()[["pt_id"]], "</b></h5>")
|
| 262 |
}) |
|
| 263 | ||
| 264 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 265 | ||
| 266 | ! |
output$basic_info_table <- DT::renderDataTable( |
| 267 | ! |
expr = table_r(), |
| 268 | ! |
options = list( |
| 269 | ! |
lengthMenu = list(list(-1, 5, 10, 25), list("All", "5", "10", "25"))
|
| 270 |
) |
|
| 271 |
) |
|
| 272 | ||
| 273 | ! |
teal.widgets::verbatim_popup_srv( |
| 274 | ! |
id = "rcode", |
| 275 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 276 | ! |
title = label |
| 277 |
) |
|
| 278 | ||
| 279 |
### REPORTER |
|
| 280 | ! |
if (with_reporter) {
|
| 281 | ! |
card_fun <- function(comment, label) {
|
| 282 | ! |
card <- teal::report_card_template( |
| 283 | ! |
title = "Patient Profile Basic Info Table", |
| 284 | ! |
label = label, |
| 285 | ! |
with_filter = with_filter, |
| 286 | ! |
filter_panel_api = filter_panel_api |
| 287 |
) |
|
| 288 | ! |
card$append_text("Table", "header3")
|
| 289 | ! |
card$append_table(table_r()) |
| 290 | ! |
if (!comment == "") {
|
| 291 | ! |
card$append_text("Comment", "header3")
|
| 292 | ! |
card$append_text(comment) |
| 293 |
} |
|
| 294 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 295 | ! |
card |
| 296 |
} |
|
| 297 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 298 |
} |
|
| 299 |
### |
|
| 300 |
}) |
|
| 301 |
} |
| 1 |
#' Template: Shift by Arm by Worst Analysis Indicator Level |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a summary table of worst analysis indicator variable level per subject by arm. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_shift_by_arm |
|
| 6 |
#' @inheritParams template_arguments |
|
| 7 |
#' @param worst_flag (`character`)\cr value indicating worst analysis indicator level. |
|
| 8 |
#' |
|
| 9 |
#' @inherit template_arguments return |
|
| 10 |
#' |
|
| 11 |
#' @seealso [tm_t_shift_by_arm()] |
|
| 12 |
#' |
|
| 13 |
#' @keywords internal |
|
| 14 |
template_shift_by_arm_by_worst <- function(dataname, |
|
| 15 |
parentname, |
|
| 16 |
arm_var = "ARM", |
|
| 17 |
paramcd = "PARAMCD", |
|
| 18 |
worst_flag_var = "WORS02FL", |
|
| 19 |
worst_flag = "Y", |
|
| 20 |
treatment_flag_var = "ONTRTFL", |
|
| 21 |
treatment_flag = "Y", |
|
| 22 |
aval_var = "ANRIND", |
|
| 23 |
base_var = lifecycle::deprecated(), |
|
| 24 |
baseline_var = "BNRIND", |
|
| 25 |
na.rm = FALSE, # nolint: object_name. |
|
| 26 |
na_level = default_na_str(), |
|
| 27 |
add_total = FALSE, |
|
| 28 |
total_label = default_total_label(), |
|
| 29 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 30 | 3x |
if (lifecycle::is_present(base_var)) {
|
| 31 | ! |
baseline_var <- base_var |
| 32 | ! |
warning( |
| 33 | ! |
"The `base_var` argument of `template_shift_by_arm_by_worst()` ", |
| 34 | ! |
"is deprecated as of teal.modules.clinical 0.8.16. ", |
| 35 | ! |
"Please use the `baseline_var` argument instead.", |
| 36 | ! |
call. = FALSE |
| 37 |
) |
|
| 38 |
} |
|
| 39 | ||
| 40 | 3x |
checkmate::assert_string(dataname) |
| 41 | 3x |
checkmate::assert_string(parentname) |
| 42 | 3x |
checkmate::assert_string(arm_var) |
| 43 | 3x |
checkmate::assert_character(worst_flag_var, null.ok = TRUE) |
| 44 | 3x |
checkmate::assert_string(paramcd) |
| 45 | 3x |
checkmate::assert_string(aval_var) |
| 46 | 3x |
checkmate::assert_string(baseline_var) |
| 47 | 3x |
checkmate::assert_flag(na.rm) |
| 48 | 3x |
checkmate::assert_string(na_level) |
| 49 | 3x |
checkmate::assert_string(treatment_flag_var) |
| 50 | 3x |
checkmate::assert_string(treatment_flag) |
| 51 | 3x |
checkmate::assert_flag(add_total) |
| 52 | 3x |
checkmate::assert_string(total_label) |
| 53 | ||
| 54 | 3x |
y <- list() |
| 55 | ||
| 56 |
# Start data steps. |
|
| 57 | 3x |
data_list <- list() |
| 58 | 3x |
data_list <- add_expr( |
| 59 | 3x |
data_list, |
| 60 | 3x |
substitute( |
| 61 | 3x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 62 | 3x |
env = list(parentname = as.name(parentname), na_str = na_level) |
| 63 |
) |
|
| 64 |
) |
|
| 65 | ||
| 66 | 3x |
data_list <- add_expr( |
| 67 | 3x |
data_list, |
| 68 | 3x |
substitute( |
| 69 | 3x |
expr = dataname <- df_explicit_na(dataname, na_level = na_str) %>% |
| 70 | 3x |
dplyr::filter(treatment_flag_var == treatment_flag, worst_flag_var == worst_flag) %>% |
| 71 | 3x |
dplyr::mutate(postbaseline_label = "Post-Baseline"), |
| 72 | 3x |
env = list( |
| 73 | 3x |
dataname = as.name(dataname), |
| 74 | 3x |
na_str = na_level, |
| 75 | 3x |
treatment_flag_var = as.name(treatment_flag_var), |
| 76 | 3x |
treatment_flag = treatment_flag, |
| 77 | 3x |
worst_flag_var = as.name(worst_flag_var), |
| 78 | 3x |
worst_flag = worst_flag |
| 79 |
) |
|
| 80 |
) |
|
| 81 |
) |
|
| 82 | ||
| 83 | 3x |
data_list <- add_expr( |
| 84 | 3x |
data_list, |
| 85 | 3x |
substitute( |
| 86 | 3x |
expr = attr(dataname$baseline_var, "label") <- "Baseline Assessment", |
| 87 | 3x |
env = list(dataname = as.name(dataname), baseline_var = baseline_var) |
| 88 |
) |
|
| 89 |
) |
|
| 90 | ||
| 91 | 3x |
y$data <- bracket_expr(data_list) |
| 92 | ||
| 93 | 3x |
basic_table_args$title <- "Shift by Arm by Worst Table" |
| 94 | ||
| 95 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 96 | 3x |
teal.widgets::resolve_basic_table_args( |
| 97 | 3x |
user_table = basic_table_args |
| 98 |
) |
|
| 99 |
) |
|
| 100 | ||
| 101 |
# Start layout steps. |
|
| 102 | 3x |
layout_list <- list() |
| 103 | ||
| 104 | ||
| 105 | 3x |
if (add_total) {
|
| 106 | 1x |
layout_list <- add_expr( |
| 107 | 1x |
layout_list, |
| 108 | 1x |
substitute( |
| 109 | 1x |
expr = expr_basic_table_args %>% |
| 110 | 1x |
rtables::split_cols_by("postbaseline_label", split_fun = drop_split_levels) %>%
|
| 111 | 1x |
rtables::split_cols_by(aval_var) %>% |
| 112 | 1x |
rtables::split_rows_by( |
| 113 | 1x |
arm_var, |
| 114 | 1x |
split_fun = add_overall_level(total_label, first = FALSE), |
| 115 | 1x |
label_pos = "topleft", |
| 116 | 1x |
split_label = obj_label(dataname$arm_var) |
| 117 |
) %>% |
|
| 118 | 1x |
add_rowcounts() %>% |
| 119 | 1x |
analyze_vars( |
| 120 | 1x |
baseline_var, |
| 121 | 1x |
denom = "N_row", |
| 122 | 1x |
na_str = na_str, |
| 123 | 1x |
na.rm = na.rm, |
| 124 | 1x |
.stats = "count_fraction" |
| 125 |
) %>% |
|
| 126 | 1x |
append_varlabels(dataname, baseline_var, indent = 1L), |
| 127 | 1x |
env = list( |
| 128 | 1x |
aval_var = aval_var, |
| 129 | 1x |
arm_var = arm_var, |
| 130 | 1x |
baseline_var = baseline_var, |
| 131 | 1x |
dataname = as.name(dataname), |
| 132 | 1x |
na.rm = na.rm, |
| 133 | 1x |
na_str = na_level, |
| 134 | 1x |
total_label = total_label, |
| 135 | 1x |
expr_basic_table_args = parsed_basic_table_args |
| 136 |
) |
|
| 137 |
) |
|
| 138 |
) |
|
| 139 |
} else {
|
|
| 140 | 2x |
layout_list <- add_expr( |
| 141 | 2x |
layout_list, |
| 142 | 2x |
substitute( |
| 143 | 2x |
expr = expr_basic_table_args %>% |
| 144 | 2x |
rtables::split_cols_by("postbaseline_label", split_fun = drop_split_levels) %>%
|
| 145 | 2x |
rtables::split_cols_by(aval_var) %>% |
| 146 | 2x |
rtables::split_rows_by( |
| 147 | 2x |
arm_var, |
| 148 | 2x |
split_fun = drop_split_levels, |
| 149 | 2x |
label_pos = "topleft", |
| 150 | 2x |
split_label = obj_label(dataname$arm_var) |
| 151 |
) %>% |
|
| 152 | 2x |
add_rowcounts() %>% |
| 153 | 2x |
analyze_vars( |
| 154 | 2x |
baseline_var, |
| 155 | 2x |
denom = "N_row", |
| 156 | 2x |
na_str = na_str, |
| 157 | 2x |
na.rm = na.rm, |
| 158 | 2x |
.stats = "count_fraction" |
| 159 |
) %>% |
|
| 160 | 2x |
append_varlabels(dataname, baseline_var, indent = 1L), |
| 161 | 2x |
env = list( |
| 162 | 2x |
aval_var = aval_var, |
| 163 | 2x |
arm_var = arm_var, |
| 164 | 2x |
baseline_var = baseline_var, |
| 165 | 2x |
dataname = as.name(dataname), |
| 166 | 2x |
na.rm = na.rm, |
| 167 | 2x |
na_str = na_level, |
| 168 | 2x |
expr_basic_table_args = parsed_basic_table_args |
| 169 |
) |
|
| 170 |
) |
|
| 171 |
) |
|
| 172 |
} |
|
| 173 | ||
| 174 | 3x |
y$layout <- substitute( |
| 175 | 3x |
expr = lyt <- layout_pipe, |
| 176 | 3x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 177 |
) |
|
| 178 | ||
| 179 |
# Full table. |
|
| 180 | 3x |
y$table <- substitute( |
| 181 | 3x |
expr = {
|
| 182 | ! |
result <- rtables::build_table(lyt = lyt, df = dataname) |
| 183 | ! |
result |
| 184 |
}, |
|
| 185 | 3x |
env = list(dataname = as.name(dataname)) |
| 186 |
) |
|
| 187 | ||
| 188 | 3x |
y |
| 189 |
} |
|
| 190 | ||
| 191 |
#' teal Module: Shift by Arm by Worst Analysis Indicator Level |
|
| 192 |
#' |
|
| 193 |
#' This module produces a summary table of worst analysis indicator variable level per subject by arm. |
|
| 194 |
#' |
|
| 195 |
#' @inheritParams module_arguments |
|
| 196 |
#' @inheritParams template_shift_by_arm_by_worst |
|
| 197 |
#' |
|
| 198 |
#' @inherit module_arguments return |
|
| 199 |
#' |
|
| 200 |
#' @examples |
|
| 201 |
#' ADSL <- tmc_ex_adsl |
|
| 202 |
#' ADEG <- tmc_ex_adeg |
|
| 203 |
#' |
|
| 204 |
#' app <- init( |
|
| 205 |
#' data = cdisc_data( |
|
| 206 |
#' ADSL = ADSL, |
|
| 207 |
#' ADEG = ADEG, |
|
| 208 |
#' code = " |
|
| 209 |
#' ADSL <- tmc_ex_adsl |
|
| 210 |
#' ADEG <- tmc_ex_adeg |
|
| 211 |
#' " |
|
| 212 |
#' ), |
|
| 213 |
#' modules = modules( |
|
| 214 |
#' tm_t_shift_by_arm_by_worst( |
|
| 215 |
#' label = "Shift by Arm Table", |
|
| 216 |
#' dataname = "ADEG", |
|
| 217 |
#' arm_var = choices_selected( |
|
| 218 |
#' variable_choices(ADSL, subset = c("ARM", "ARMCD")),
|
|
| 219 |
#' selected = "ARM" |
|
| 220 |
#' ), |
|
| 221 |
#' paramcd = choices_selected( |
|
| 222 |
#' value_choices(ADEG, "PARAMCD"), |
|
| 223 |
#' selected = "ECGINTP" |
|
| 224 |
#' ), |
|
| 225 |
#' worst_flag_var = choices_selected( |
|
| 226 |
#' variable_choices(ADEG, c("WORS02FL", "WORS01FL")),
|
|
| 227 |
#' selected = "WORS02FL" |
|
| 228 |
#' ), |
|
| 229 |
#' worst_flag = choices_selected( |
|
| 230 |
#' value_choices(ADEG, "WORS02FL"), |
|
| 231 |
#' selected = "Y", fixed = TRUE |
|
| 232 |
#' ), |
|
| 233 |
#' aval_var = choices_selected( |
|
| 234 |
#' variable_choices(ADEG, c("AVALC", "ANRIND")),
|
|
| 235 |
#' selected = "AVALC" |
|
| 236 |
#' ), |
|
| 237 |
#' baseline_var = choices_selected( |
|
| 238 |
#' variable_choices(ADEG, c("BASEC", "BNRIND")),
|
|
| 239 |
#' selected = "BASEC" |
|
| 240 |
#' ), |
|
| 241 |
#' useNA = "ifany" |
|
| 242 |
#' ) |
|
| 243 |
#' ) |
|
| 244 |
#' ) |
|
| 245 |
#' if (interactive()) {
|
|
| 246 |
#' shinyApp(app$ui, app$server) |
|
| 247 |
#' } |
|
| 248 |
#' |
|
| 249 |
#' @export |
|
| 250 |
tm_t_shift_by_arm_by_worst <- function(label, |
|
| 251 |
dataname, |
|
| 252 |
parentname = ifelse( |
|
| 253 |
inherits(arm_var, "data_extract_spec"), |
|
| 254 |
teal.transform::datanames_input(arm_var), |
|
| 255 |
"ADSL" |
|
| 256 |
), |
|
| 257 |
arm_var, |
|
| 258 |
paramcd, |
|
| 259 |
aval_var, |
|
| 260 |
base_var = lifecycle::deprecated(), |
|
| 261 |
baseline_var, |
|
| 262 |
worst_flag_var, |
|
| 263 |
worst_flag, |
|
| 264 |
treatment_flag_var = teal.transform::choices_selected( |
|
| 265 |
choices = teal.transform::variable_choices(dataname, subset = "ONTRTFL"), |
|
| 266 |
selected = "ONTRTFL" |
|
| 267 |
), |
|
| 268 |
treatment_flag = teal.transform::choices_selected("Y"),
|
|
| 269 |
useNA = c("ifany", "no"), # nolint: object_name.
|
|
| 270 |
na_level = default_na_str(), |
|
| 271 |
add_total = FALSE, |
|
| 272 |
total_label = default_total_label(), |
|
| 273 |
pre_output = NULL, |
|
| 274 |
post_output = NULL, |
|
| 275 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 276 | ! |
if (lifecycle::is_present(base_var)) {
|
| 277 | ! |
baseline_var <- base_var |
| 278 | ! |
warning( |
| 279 | ! |
"The `base_var` argument of `tm_t_shift_by_arm_by_worst()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 280 | ! |
"Please use the `baseline_var` argument instead.", |
| 281 | ! |
call. = FALSE |
| 282 |
) |
|
| 283 |
} else {
|
|
| 284 | ! |
base_var <- baseline_var # resolves missing argument error |
| 285 |
} |
|
| 286 | ||
| 287 | ! |
message("Initializing tm_t_shift_by_arm_by_worst")
|
| 288 | ! |
checkmate::assert_string(label) |
| 289 | ! |
checkmate::assert_string(dataname) |
| 290 | ! |
checkmate::assert_string(parentname) |
| 291 | ! |
useNA <- match.arg(useNA) # nolint: object_name. |
| 292 | ! |
checkmate::assert_string(na_level) |
| 293 | ! |
checkmate::assert_string(total_label) |
| 294 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 295 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 296 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 297 | ! |
checkmate::assert_class(baseline_var, "choices_selected") |
| 298 | ! |
checkmate::assert_class(worst_flag_var, "choices_selected") |
| 299 | ! |
checkmate::assert_class(treatment_flag_var, "choices_selected") |
| 300 | ! |
checkmate::assert_class(treatment_flag, "choices_selected") |
| 301 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 302 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 303 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 304 | ! |
args <- as.list(environment()) |
| 305 | ||
| 306 | ||
| 307 | ! |
data_extract_list <- list( |
| 308 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 309 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 310 | ! |
treatment_flag_var = cs_to_des_select(treatment_flag_var, dataname = dataname), |
| 311 | ! |
worst_flag_var = cs_to_des_select(worst_flag_var, dataname = dataname), |
| 312 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 313 | ! |
baseline_var = cs_to_des_select(baseline_var, dataname = dataname) |
| 314 |
) |
|
| 315 | ||
| 316 | ||
| 317 | ! |
module( |
| 318 | ! |
label = label, |
| 319 | ! |
server = srv_shift_by_arm_by_worst, |
| 320 | ! |
ui = ui_shift_by_arm_by_worst, |
| 321 | ! |
ui_args = c(data_extract_list, args), |
| 322 | ! |
server_args = c( |
| 323 | ! |
data_extract_list, |
| 324 | ! |
list( |
| 325 | ! |
dataname = dataname, |
| 326 | ! |
parentname = parentname, |
| 327 | ! |
label = label, |
| 328 | ! |
treatment_flag = treatment_flag, |
| 329 | ! |
total_label = total_label, |
| 330 | ! |
na_level = na_level, |
| 331 | ! |
basic_table_args = basic_table_args |
| 332 |
) |
|
| 333 |
), |
|
| 334 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 335 |
) |
|
| 336 |
} |
|
| 337 | ||
| 338 |
#' @keywords internal |
|
| 339 |
ui_shift_by_arm_by_worst <- function(id, ...) {
|
|
| 340 | ! |
ns <- NS(id) |
| 341 | ! |
a <- list(...) |
| 342 | ||
| 343 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 344 | ! |
a$id_var, |
| 345 | ! |
a$arm_var, |
| 346 | ! |
a$paramcd, |
| 347 | ! |
a$worst_flag_var, |
| 348 | ! |
a$treatment_flag_var, |
| 349 | ! |
a$treatment_flag, |
| 350 | ! |
a$aval_var, |
| 351 | ! |
a$baseline_var |
| 352 |
) |
|
| 353 | ! |
teal.widgets::standard_layout( |
| 354 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 355 | ! |
encoding = tags$div( |
| 356 |
### Reporter |
|
| 357 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 358 |
### |
|
| 359 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 360 | ! |
teal.transform::datanames_input(a[c( |
| 361 | ! |
"arm_var", "paramcd_var", "paramcd", "aval_var", |
| 362 | ! |
"baseline_var", "worst_flag_var", "worst_flag", "treamtment_flag_var" |
| 363 |
)]), |
|
| 364 | ! |
teal.transform::data_extract_ui( |
| 365 | ! |
id = ns("arm_var"),
|
| 366 | ! |
label = "Select Treatment Variable", |
| 367 | ! |
data_extract_spec = a$arm_var, |
| 368 | ! |
is_single_dataset = is_single_dataset_value |
| 369 |
), |
|
| 370 | ! |
teal.transform::data_extract_ui( |
| 371 | ! |
id = ns("paramcd"),
|
| 372 | ! |
label = "Select Endpoint", |
| 373 | ! |
data_extract_spec = a$paramcd, |
| 374 | ! |
is_single_dataset = is_single_dataset_value |
| 375 |
), |
|
| 376 | ! |
teal.transform::data_extract_ui( |
| 377 | ! |
id = ns("worst_flag_var"),
|
| 378 | ! |
label = "Select The worst flag", |
| 379 | ! |
data_extract_spec = a$worst_flag_var, |
| 380 | ! |
is_single_dataset = is_single_dataset_value |
| 381 |
), |
|
| 382 | ! |
teal.widgets::optionalSelectInput( |
| 383 | ! |
ns("worst_flag"),
|
| 384 | ! |
"Value of worst flag", |
| 385 | ! |
a$worst_flag$choices, |
| 386 | ! |
a$worst_flag$selected, |
| 387 | ! |
multiple = FALSE, |
| 388 | ! |
fixed = a$worst_flag$fixed |
| 389 |
), |
|
| 390 | ! |
teal.transform::data_extract_ui( |
| 391 | ! |
id = ns("aval_var"),
|
| 392 | ! |
label = "Select Analysis Value", |
| 393 | ! |
data_extract_spec = a$aval_var, |
| 394 | ! |
is_single_dataset = is_single_dataset_value |
| 395 |
), |
|
| 396 | ! |
teal.transform::data_extract_ui( |
| 397 | ! |
id = ns("baseline_var"),
|
| 398 | ! |
label = "Select Baseline Value", |
| 399 | ! |
data_extract_spec = a$baseline_var, |
| 400 | ! |
is_single_dataset = is_single_dataset_value |
| 401 |
), |
|
| 402 | ! |
checkboxInput(ns("add_total"), "Add All Patients row", value = a$add_total),
|
| 403 | ! |
radioButtons( |
| 404 | ! |
ns("useNA"),
|
| 405 | ! |
label = "Display NA counts", |
| 406 | ! |
choices = c("ifany", "no"),
|
| 407 | ! |
selected = a$useNA |
| 408 |
), |
|
| 409 | ! |
teal.widgets::panel_group( |
| 410 | ! |
teal.widgets::panel_item( |
| 411 | ! |
"Additional Variables Info", |
| 412 | ! |
teal.transform::data_extract_ui( |
| 413 | ! |
id = ns("treatment_flag_var"),
|
| 414 | ! |
label = "On Treatment Flag Variable", |
| 415 | ! |
data_extract_spec = a$treatment_flag_var, |
| 416 | ! |
is_single_dataset = is_single_dataset_value |
| 417 |
), |
|
| 418 | ! |
teal.widgets::optionalSelectInput( |
| 419 | ! |
inputId = ns("treatment_flag"),
|
| 420 | ! |
label = "Value Indicating On Treatment", |
| 421 | ! |
multiple = FALSE, |
| 422 | ! |
fixed_on_single = TRUE |
| 423 |
) |
|
| 424 |
) |
|
| 425 |
) |
|
| 426 |
), |
|
| 427 | ! |
forms = tagList( |
| 428 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 429 |
), |
|
| 430 | ! |
pre_output = a$pre_output, |
| 431 | ! |
post_output = a$post_output |
| 432 |
) |
|
| 433 |
} |
|
| 434 | ||
| 435 |
#' @keywords internal |
|
| 436 |
srv_shift_by_arm_by_worst <- function(id, |
|
| 437 |
data, |
|
| 438 |
reporter, |
|
| 439 |
filter_panel_api, |
|
| 440 |
dataname, |
|
| 441 |
parentname, |
|
| 442 |
arm_var, |
|
| 443 |
paramcd, |
|
| 444 |
treatment_flag_var, |
|
| 445 |
treatment_flag, |
|
| 446 |
worst_flag_var, |
|
| 447 |
aval_var, |
|
| 448 |
baseline_var, |
|
| 449 |
label, |
|
| 450 |
na_level, |
|
| 451 |
add_total, |
|
| 452 |
total_label, |
|
| 453 |
basic_table_args) {
|
|
| 454 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 455 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 456 | ! |
checkmate::assert_class(data, "reactive") |
| 457 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 458 | ! |
moduleServer(id, function(input, output, session) {
|
| 459 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 460 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 461 | ! |
data_extract = list( |
| 462 | ! |
arm_var = arm_var, |
| 463 | ! |
treatment_flag_var = treatment_flag_var, |
| 464 | ! |
worst_flag_var = worst_flag_var, |
| 465 | ! |
aval_var = aval_var, |
| 466 | ! |
baseline_var = baseline_var, |
| 467 | ! |
paramcd = paramcd |
| 468 |
), |
|
| 469 | ! |
datasets = data, |
| 470 | ! |
select_validation_rule = list( |
| 471 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required"),
|
| 472 | ! |
treatment_flag_var = shinyvalidate::sv_required("A treatment flag variable is required"),
|
| 473 | ! |
worst_flag_var = shinyvalidate::sv_required("A worst flag variable is required"),
|
| 474 | ! |
aval_var = shinyvalidate::sv_required("An analysis range indicator required"),
|
| 475 | ! |
baseline_var = shinyvalidate::sv_required("A baseline reference range indicator is required")
|
| 476 |
), |
|
| 477 | ! |
filter_validation_rule = list( |
| 478 | ! |
paramcd = shinyvalidate::sv_required("An endpoint is required")
|
| 479 |
) |
|
| 480 |
) |
|
| 481 | ||
| 482 | ! |
isolate({
|
| 483 | ! |
resolved <- teal.transform::resolve_delayed(treatment_flag, as.list(data()@env)) |
| 484 | ! |
teal.widgets::updateOptionalSelectInput( |
| 485 | ! |
session = session, |
| 486 | ! |
inputId = "treatment_flag", |
| 487 | ! |
choices = resolved$choices, |
| 488 | ! |
selected = resolved$selected |
| 489 |
) |
|
| 490 |
}) |
|
| 491 | ||
| 492 | ! |
iv_r <- reactive({
|
| 493 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 494 | ! |
iv$add_rule( |
| 495 | ! |
"treatment_flag", |
| 496 | ! |
shinyvalidate::sv_required("An indicator value for on treatment records is required")
|
| 497 |
) |
|
| 498 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 499 |
}) |
|
| 500 | ||
| 501 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 502 | ! |
datasets = data, |
| 503 | ! |
selector_list = selector_list, |
| 504 | ! |
merge_function = "dplyr::inner_join" |
| 505 |
) |
|
| 506 | ||
| 507 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 508 | ! |
datasets = data, |
| 509 | ! |
data_extract = list(arm_var = arm_var), |
| 510 | ! |
anl_name = "ANL_ADSL" |
| 511 |
) |
|
| 512 | ||
| 513 | ! |
anl_q <- reactive({
|
| 514 | ! |
data() %>% |
| 515 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 516 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 517 |
}) |
|
| 518 | ||
| 519 | ! |
merged <- list( |
| 520 | ! |
anl_input_r = anl_inputs, |
| 521 | ! |
adsl_input_r = adsl_inputs, |
| 522 | ! |
anl_q = anl_q |
| 523 |
) |
|
| 524 | ||
| 525 |
# validate inputs |
|
| 526 | ! |
validate_checks <- reactive({
|
| 527 | ! |
teal::validate_inputs(iv_r()) |
| 528 | ||
| 529 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 530 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 531 | ||
| 532 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 533 | ! |
input_aval_var <- names(merged$anl_input_r()$columns_source$aval_var) |
| 534 | ! |
input_baseline_var <- names(merged$anl_input_r()$columns_source$baseline_var) |
| 535 | ||
| 536 | ! |
validate( |
| 537 | ! |
need( |
| 538 | ! |
nrow(merged$anl_q()[["ANL"]]) > 0, |
| 539 | ! |
paste0( |
| 540 | ! |
"Please make sure the analysis dataset is not empty or\n", |
| 541 | ! |
"endpoint parameter and analysis visit are selected." |
| 542 |
) |
|
| 543 |
), |
|
| 544 | ! |
need( |
| 545 | ! |
length(unique(merged$anl_q()[["ANL"]][[input_aval_var]])) < 50, |
| 546 | ! |
paste( |
| 547 | ! |
"There are too many values of", input_aval_var, "for the selected endpoint.", |
| 548 | ! |
"Please select either a different endpoint or a different analysis value." |
| 549 |
) |
|
| 550 |
), |
|
| 551 | ! |
need( |
| 552 | ! |
length(unique(merged$anl_q()[["ANL"]][[input_baseline_var]])) < 50, |
| 553 | ! |
paste( |
| 554 | ! |
"There are too many values of", input_baseline_var, "for the selected endpoint.", |
| 555 | ! |
"Please select either a different endpoint or a different baseline value." |
| 556 |
) |
|
| 557 |
) |
|
| 558 |
) |
|
| 559 | ||
| 560 | ! |
validate_standard_inputs( |
| 561 | ! |
adsl = adsl_filtered, |
| 562 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 563 | ! |
anl = anl_filtered, |
| 564 | ! |
anlvars = c("USUBJID", "STUDYID", input_aval_var, input_baseline_var),
|
| 565 | ! |
arm_var = input_arm_var |
| 566 |
) |
|
| 567 |
}) |
|
| 568 | ||
| 569 |
# generate r code for the analysis |
|
| 570 | ! |
all_q <- reactive({
|
| 571 | ! |
validate_checks() |
| 572 | ||
| 573 | ! |
my_calls <- template_shift_by_arm_by_worst( |
| 574 | ! |
dataname = "ANL", |
| 575 | ! |
parentname = "ANL_ADSL", |
| 576 | ! |
arm_var = names(merged$anl_input_r()$columns_source$arm_var), |
| 577 | ! |
paramcd = unlist(paramcd$filter)["vars_selected"], |
| 578 | ! |
worst_flag_var = names(merged$anl_input_r()$columns_source$worst_flag_var), |
| 579 | ! |
worst_flag = input$worst_flag, |
| 580 | ! |
treatment_flag_var = names(merged$anl_input_r()$columns_source$treatment_flag_var), |
| 581 | ! |
treatment_flag = input$treatment_flag, |
| 582 | ! |
aval_var = names(merged$anl_input_r()$columns_source$aval_var), |
| 583 | ! |
baseline_var = names(merged$anl_input_r()$columns_source$baseline_var), |
| 584 | ! |
na.rm = ifelse(input$useNA == "ifany", FALSE, TRUE), |
| 585 | ! |
na_level = na_level, |
| 586 | ! |
add_total = input$add_total, |
| 587 | ! |
total_label = total_label, |
| 588 | ! |
basic_table_args = basic_table_args |
| 589 |
) |
|
| 590 | ||
| 591 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 592 |
}) |
|
| 593 | ||
| 594 |
# Outputs to render. |
|
| 595 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 596 | ||
| 597 | ! |
teal.widgets::table_with_settings_srv( |
| 598 | ! |
id = "table", |
| 599 | ! |
table_r = table_r |
| 600 |
) |
|
| 601 | ||
| 602 |
# Render R code. |
|
| 603 | ! |
teal.widgets::verbatim_popup_srv( |
| 604 | ! |
id = "rcode", |
| 605 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 606 | ! |
title = label |
| 607 |
) |
|
| 608 | ||
| 609 |
### REPORTER |
|
| 610 | ! |
if (with_reporter) {
|
| 611 | ! |
card_fun <- function(comment, label) {
|
| 612 | ! |
card <- teal::report_card_template( |
| 613 | ! |
title = "Shift by Arm by Worst Table", |
| 614 | ! |
label = label, |
| 615 | ! |
with_filter = with_filter, |
| 616 | ! |
filter_panel_api = filter_panel_api |
| 617 |
) |
|
| 618 | ! |
card$append_text("Table", "header3")
|
| 619 | ! |
card$append_table(table_r()) |
| 620 | ! |
if (!comment == "") {
|
| 621 | ! |
card$append_text("Comment", "header3")
|
| 622 | ! |
card$append_text(comment) |
| 623 |
} |
|
| 624 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 625 | ! |
card |
| 626 |
} |
|
| 627 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 628 |
} |
|
| 629 |
### |
|
| 630 |
}) |
|
| 631 |
} |
| 1 |
#' Template: Adverse Events Table by Standardized MedDRA Query |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate an adverse events table by Standardized MedDRA Query. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param smq_varlabel (`character`)\cr label to use for new column `SMQ` created by [tern::h_stack_by_baskets()]. |
|
| 7 |
#' @param baskets (`character`)\cr names of the selected standardized/customized queries variables. |
|
| 8 |
#' |
|
| 9 |
#' @inherit template_arguments return |
|
| 10 |
#' |
|
| 11 |
#' @seealso [tm_t_smq()] |
|
| 12 |
#' |
|
| 13 |
#' @keywords internal |
|
| 14 |
template_smq <- function(dataname, |
|
| 15 |
parentname, |
|
| 16 |
arm_var, |
|
| 17 |
llt = "AEDECOD", |
|
| 18 |
add_total = TRUE, |
|
| 19 |
total_label = default_total_label(), |
|
| 20 |
sort_criteria = c("freq_desc", "alpha"),
|
|
| 21 |
drop_arm_levels = TRUE, |
|
| 22 |
na_level = default_na_str(), |
|
| 23 |
smq_varlabel = "Standardized MedDRA Query", |
|
| 24 |
baskets = c("SMQ01NAM", "SMQ02NAM", "CQ01NAM"),
|
|
| 25 |
id_var = "USUBJID", |
|
| 26 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 27 | 2x |
checkmate::assert_string(parentname) |
| 28 | 2x |
checkmate::assert_string(dataname) |
| 29 | 2x |
checkmate::assert_character(arm_var, min.len = 1, max.len = 2) |
| 30 | 2x |
checkmate::assert_string(id_var) |
| 31 | 2x |
checkmate::assert_string(llt) |
| 32 | 2x |
checkmate::assert_flag(add_total) |
| 33 | 2x |
checkmate::assert_string(total_label) |
| 34 | 2x |
checkmate::assert_flag(drop_arm_levels) |
| 35 | 2x |
checkmate::assert_string(na_level) |
| 36 | 2x |
checkmate::assert_string(smq_varlabel) |
| 37 | 2x |
checkmate::assert_character(baskets) |
| 38 | ||
| 39 | 2x |
sort_criteria <- match.arg(sort_criteria) |
| 40 | ||
| 41 | 2x |
y <- list() |
| 42 | ||
| 43 | 2x |
data_list <- list() |
| 44 | ||
| 45 | 2x |
data_list <- add_expr( |
| 46 | 2x |
data_list, |
| 47 | 2x |
substitute( |
| 48 | 2x |
anl <- dataname, |
| 49 | 2x |
env = list( |
| 50 | 2x |
dataname = as.name(dataname) |
| 51 |
) |
|
| 52 |
) |
|
| 53 |
) |
|
| 54 | ||
| 55 | 2x |
data_list <- add_expr( |
| 56 | 2x |
data_list, |
| 57 | 2x |
prepare_arm_levels( |
| 58 | 2x |
dataname = "anl", |
| 59 | 2x |
parentname = parentname, |
| 60 | 2x |
arm_var = arm_var[[1]], |
| 61 | 2x |
drop_arm_levels = drop_arm_levels |
| 62 |
) |
|
| 63 |
) |
|
| 64 | ||
| 65 | 2x |
if (length(arm_var) == 2) {
|
| 66 | 1x |
data_list <- add_expr( |
| 67 | 1x |
data_list, |
| 68 | 1x |
prepare_arm_levels( |
| 69 | 1x |
dataname = "anl", |
| 70 | 1x |
parentname = parentname, |
| 71 | 1x |
arm_var = arm_var[[2]], |
| 72 | 1x |
drop_arm_levels = drop_arm_levels |
| 73 |
) |
|
| 74 |
) |
|
| 75 |
} |
|
| 76 | ||
| 77 | 2x |
data_list <- add_expr( |
| 78 | 2x |
data_list, |
| 79 | 2x |
substitute( |
| 80 | 2x |
anl <- h_stack_by_baskets( |
| 81 | 2x |
df = dataname, |
| 82 | 2x |
baskets = baskets, |
| 83 | 2x |
smq_varlabel = smq_varlabel, |
| 84 | 2x |
keys = unique(c("STUDYID", id_var, arm_var, llt))
|
| 85 |
), |
|
| 86 | 2x |
env = list( |
| 87 | 2x |
dataname = as.name("anl"),
|
| 88 | 2x |
baskets = baskets, |
| 89 | 2x |
smq_varlabel = smq_varlabel, |
| 90 | 2x |
id_var = id_var, |
| 91 | 2x |
arm_var = arm_var, |
| 92 | 2x |
llt = llt |
| 93 |
) |
|
| 94 |
) |
|
| 95 |
) |
|
| 96 | ||
| 97 | 2x |
data_list <- add_expr( |
| 98 | 2x |
data_list, |
| 99 | 2x |
quote( |
| 100 | 2x |
if (nrow(anl) == 0) {
|
| 101 | ! |
stop("Analysis dataset contains only missing values")
|
| 102 |
} |
|
| 103 |
) |
|
| 104 |
) |
|
| 105 | ||
| 106 | 2x |
data_list <- add_expr( |
| 107 | 2x |
data_list, |
| 108 | 2x |
substitute( |
| 109 | 2x |
anl <- df_explicit_na( |
| 110 | 2x |
dataname, |
| 111 | 2x |
na_level = na_str |
| 112 |
), |
|
| 113 | 2x |
env = list( |
| 114 | 2x |
dataname = as.name("anl"),
|
| 115 | 2x |
na_str = na_level |
| 116 |
) |
|
| 117 |
) |
|
| 118 |
) |
|
| 119 | ||
| 120 | 2x |
data_list <- add_expr( |
| 121 | 2x |
data_list, |
| 122 | 2x |
substitute( |
| 123 | 2x |
parentname <- df_explicit_na( |
| 124 | 2x |
parentname, |
| 125 | 2x |
na_level = na_str |
| 126 |
), |
|
| 127 | 2x |
env = list( |
| 128 | 2x |
parentname = as.name(parentname), |
| 129 | 2x |
na_str = na_level |
| 130 |
) |
|
| 131 |
) |
|
| 132 |
) |
|
| 133 | ||
| 134 | 2x |
y$data <- bracket_expr(data_list) |
| 135 | ||
| 136 | 2x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 137 | 2x |
teal.widgets::resolve_basic_table_args( |
| 138 | 2x |
user_table = basic_table_args, |
| 139 | 2x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE) |
| 140 |
) |
|
| 141 |
) |
|
| 142 | ||
| 143 |
# Start layout steps. |
|
| 144 | 2x |
layout_list <- list() |
| 145 | 2x |
layout_list <- add_expr( |
| 146 | 2x |
layout_list, |
| 147 | 2x |
substitute( |
| 148 | 2x |
expr = expr_basic_table_args %>% |
| 149 | 2x |
rtables::split_cols_by(var = arm_var), |
| 150 | 2x |
env = list(arm_var = arm_var[[1]], expr_basic_table_args = parsed_basic_table_args) |
| 151 |
) |
|
| 152 |
) |
|
| 153 | ||
| 154 | 2x |
if (length(arm_var) == 2) {
|
| 155 | 1x |
layout_list <- add_expr( |
| 156 | 1x |
layout_list, |
| 157 | 1x |
if (drop_arm_levels) {
|
| 158 | ! |
substitute( |
| 159 | ! |
expr = rtables::split_cols_by(var = nested_col, split_fun = drop_split_levels), |
| 160 | ! |
env = list(nested_col = arm_var[[2]]) |
| 161 |
) |
|
| 162 |
} else {
|
|
| 163 | 1x |
substitute( |
| 164 | 1x |
expr = rtables::split_cols_by(var = nested_col), |
| 165 | 1x |
env = list(nested_col = arm_var[[2]]) |
| 166 |
) |
|
| 167 |
} |
|
| 168 |
) |
|
| 169 |
} |
|
| 170 | ||
| 171 | 2x |
if (add_total) {
|
| 172 | ! |
layout_list <- add_expr( |
| 173 | ! |
layout_list, |
| 174 | ! |
substitute( |
| 175 | ! |
expr = rtables::add_overall_col(total_label), |
| 176 | ! |
env = list(total_label = total_label) |
| 177 |
) |
|
| 178 |
) |
|
| 179 |
} |
|
| 180 | ||
| 181 | 2x |
layout_list <- add_expr( |
| 182 | 2x |
layout_list, |
| 183 | 2x |
substitute( |
| 184 | 2x |
expr = summarize_num_patients( |
| 185 | 2x |
var = id_var, |
| 186 | 2x |
.stats = c("unique"),
|
| 187 | 2x |
.labels = c( |
| 188 | 2x |
unique = "Total number of patients with at least one adverse event" |
| 189 |
) |
|
| 190 |
), |
|
| 191 | 2x |
env = list( |
| 192 | 2x |
id_var = id_var |
| 193 |
) |
|
| 194 |
) |
|
| 195 |
) |
|
| 196 | ||
| 197 | 2x |
split_label <- substitute( |
| 198 | 2x |
expr = teal.data::col_labels(dataname, fill = FALSE)[["SMQ"]], |
| 199 | 2x |
env = list( |
| 200 | 2x |
dataname = as.name("anl")
|
| 201 |
) |
|
| 202 |
) |
|
| 203 | ||
| 204 | 2x |
layout_list <- add_expr( |
| 205 | 2x |
layout_list, |
| 206 | 2x |
substitute( |
| 207 | 2x |
expr = rtables::split_rows_by( |
| 208 | 2x |
"SMQ", |
| 209 | 2x |
child_labels = "visible", |
| 210 | 2x |
nested = FALSE, |
| 211 | 2x |
split_fun = trim_levels_in_group(llt, drop_outlevs = FALSE), |
| 212 | 2x |
indent_mod = -1L, |
| 213 | 2x |
label_pos = "topleft", |
| 214 | 2x |
split_label = split_label |
| 215 |
), |
|
| 216 | 2x |
env = list( |
| 217 | 2x |
llt = llt, |
| 218 | 2x |
split_label = split_label |
| 219 |
) |
|
| 220 |
) |
|
| 221 |
) |
|
| 222 | ||
| 223 | 2x |
layout_list <- add_expr( |
| 224 | 2x |
layout_list, |
| 225 | 2x |
substitute( |
| 226 | 2x |
expr = summarize_num_patients( |
| 227 | 2x |
var = id_var, |
| 228 | 2x |
.stats = c("unique", "nonunique"),
|
| 229 | 2x |
.labels = c( |
| 230 | 2x |
unique = "Total number of patients with at least one adverse event", |
| 231 | 2x |
nonunique = "Total number of events" |
| 232 |
) |
|
| 233 |
), |
|
| 234 | 2x |
env = list( |
| 235 | 2x |
id_var = id_var |
| 236 |
) |
|
| 237 |
) |
|
| 238 |
) |
|
| 239 | ||
| 240 | 2x |
layout_list <- add_expr( |
| 241 | 2x |
layout_list, |
| 242 | 2x |
substitute( |
| 243 | 2x |
expr = count_occurrences(vars = llt, drop = FALSE), |
| 244 | 2x |
env = list( |
| 245 | 2x |
llt = llt |
| 246 |
) |
|
| 247 |
) |
|
| 248 |
) |
|
| 249 | ||
| 250 | 2x |
layout_list <- add_expr( |
| 251 | 2x |
layout_list, |
| 252 | 2x |
substitute( |
| 253 | 2x |
expr = append_varlabels(dataname, llt, indent = 1L), |
| 254 | 2x |
env = list( |
| 255 | 2x |
dataname = as.name("anl"),
|
| 256 | 2x |
llt = llt |
| 257 |
) |
|
| 258 |
) |
|
| 259 |
) |
|
| 260 | ||
| 261 | 2x |
y$layout <- substitute( |
| 262 | 2x |
expr = lyt <- layout_pipe, |
| 263 | 2x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 264 |
) |
|
| 265 | ||
| 266 | 2x |
y$table <- substitute( |
| 267 | 2x |
expr = {
|
| 268 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 269 |
}, |
|
| 270 | 2x |
env = list(parent = as.name(parentname)) |
| 271 |
) |
|
| 272 | ||
| 273 | 2x |
if (sort_criteria == "freq_desc") {
|
| 274 | 2x |
y$sort <- substitute( |
| 275 | 2x |
expr = {
|
| 276 | ! |
sorted_result <- result %>% |
| 277 | ! |
sort_at_path(path = c("SMQ"), scorefun = cont_n_allcols) %>%
|
| 278 | ! |
sort_at_path(path = c("SMQ", "*", llt), scorefun = score_occurrences, na.pos = "last")
|
| 279 |
}, |
|
| 280 | 2x |
env = list(llt = llt) |
| 281 |
) |
|
| 282 |
} else {
|
|
| 283 | ! |
y$sort <- quote( |
| 284 | ! |
sorted_result <- result |
| 285 |
) |
|
| 286 |
} |
|
| 287 | ||
| 288 | 2x |
y$sort_and_prune <- quote( |
| 289 | 2x |
expr = {
|
| 290 | ! |
all_zero <- function(tr) {
|
| 291 | ! |
!inherits(tr, "ContentRow") && rtables::all_zero_or_na(tr) |
| 292 |
} |
|
| 293 | ! |
pruned_and_sorted_result <- sorted_result %>% rtables::trim_rows(criteria = all_zero) |
| 294 | ! |
pruned_and_sorted_result |
| 295 |
} |
|
| 296 |
) |
|
| 297 | ||
| 298 | 2x |
y |
| 299 |
} |
|
| 300 | ||
| 301 |
#' teal Module: Adverse Events Table by Standardized MedDRA Query |
|
| 302 |
#' |
|
| 303 |
#' This module produces an adverse events table by Standardized MedDRA Query. |
|
| 304 |
#' |
|
| 305 |
#' @inheritParams module_arguments |
|
| 306 |
#' @inheritParams template_smq |
|
| 307 |
#' @param arm_var ([teal.transform::choices_selected()])\cr object with all |
|
| 308 |
#' available choices and preselected option for variable names that can be used as `arm_var`. |
|
| 309 |
#' It defines the grouping variable(s) in the results table. |
|
| 310 |
#' If there are two elements selected for `arm_var`, |
|
| 311 |
#' second variable will be nested under the first variable. |
|
| 312 |
#' @param baskets ([teal.transform::choices_selected()])\cr object with all |
|
| 313 |
#' available choices and preselected options for standardized/customized queries. |
|
| 314 |
#' @param scopes ([teal.transform::choices_selected()])\cr object with all |
|
| 315 |
#' available choices for the scopes of standardized queries. |
|
| 316 |
#' |
|
| 317 |
#' @inherit module_arguments return seealso |
|
| 318 |
#' |
|
| 319 |
#' @examples |
|
| 320 |
#' data <- teal_data() |
|
| 321 |
#' data <- within(data, {
|
|
| 322 |
#' ADSL <- tmc_ex_adsl |
|
| 323 |
#' ADAE <- tmc_ex_adae |
|
| 324 |
#' |
|
| 325 |
#' names_baskets <- grep("^(SMQ|CQ).*NAM$", names(ADAE), value = TRUE)
|
|
| 326 |
#' names_scopes <- grep("^SMQ.*SC$", names(ADAE), value = TRUE)
|
|
| 327 |
#' |
|
| 328 |
#' cs_baskets <- choices_selected( |
|
| 329 |
#' choices = variable_choices(ADAE, subset = names_baskets), |
|
| 330 |
#' selected = names_baskets |
|
| 331 |
#' ) |
|
| 332 |
#' |
|
| 333 |
#' cs_scopes <- choices_selected( |
|
| 334 |
#' choices = variable_choices(ADAE, subset = names_scopes), |
|
| 335 |
#' selected = names_scopes, |
|
| 336 |
#' fixed = TRUE |
|
| 337 |
#' ) |
|
| 338 |
#' }) |
|
| 339 |
#' |
|
| 340 |
#' datanames <- c("ADSL", "ADAE")
|
|
| 341 |
#' datanames(data) <- datanames |
|
| 342 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 343 |
#' |
|
| 344 |
#' app <- init( |
|
| 345 |
#' data = data, |
|
| 346 |
#' modules = modules( |
|
| 347 |
#' tm_t_smq( |
|
| 348 |
#' label = "Adverse Events by SMQ Table", |
|
| 349 |
#' dataname = "ADAE", |
|
| 350 |
#' arm_var = choices_selected( |
|
| 351 |
#' choices = variable_choices(data[["ADSL"]], subset = c("ARM", "SEX")),
|
|
| 352 |
#' selected = "ARM" |
|
| 353 |
#' ), |
|
| 354 |
#' add_total = FALSE, |
|
| 355 |
#' baskets = data[["cs_baskets"]], |
|
| 356 |
#' scopes = data[["cs_scopes"]], |
|
| 357 |
#' llt = choices_selected( |
|
| 358 |
#' choices = variable_choices(data[["ADAE"]], subset = c("AEDECOD")),
|
|
| 359 |
#' selected = "AEDECOD" |
|
| 360 |
#' ) |
|
| 361 |
#' ) |
|
| 362 |
#' ) |
|
| 363 |
#' ) |
|
| 364 |
#' if (interactive()) {
|
|
| 365 |
#' shinyApp(app$ui, app$server) |
|
| 366 |
#' } |
|
| 367 |
#' |
|
| 368 |
#' @export |
|
| 369 |
tm_t_smq <- function(label, |
|
| 370 |
dataname, |
|
| 371 |
parentname = ifelse( |
|
| 372 |
inherits(arm_var, "data_extract_spec"), |
|
| 373 |
teal.transform::datanames_input(arm_var), |
|
| 374 |
"ADSL" |
|
| 375 |
), |
|
| 376 |
arm_var, |
|
| 377 |
id_var = teal.transform::choices_selected( |
|
| 378 |
teal.transform::variable_choices(dataname, subset = "USUBJID"), |
|
| 379 |
selected = "USUBJID", fixed = TRUE |
|
| 380 |
), |
|
| 381 |
llt, |
|
| 382 |
add_total = TRUE, |
|
| 383 |
total_label = default_total_label(), |
|
| 384 |
sort_criteria = c("freq_desc", "alpha"),
|
|
| 385 |
drop_arm_levels = TRUE, |
|
| 386 |
na_level = default_na_str(), |
|
| 387 |
smq_varlabel = "Standardized MedDRA Query", |
|
| 388 |
baskets, |
|
| 389 |
scopes, |
|
| 390 |
pre_output = NULL, |
|
| 391 |
post_output = NULL, |
|
| 392 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 393 | ! |
message("Initializing tm_t_smq")
|
| 394 | ! |
checkmate::assert_string(label) |
| 395 | ! |
checkmate::assert_string(dataname) |
| 396 | ! |
checkmate::assert_string(parentname) |
| 397 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 398 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 399 | ! |
checkmate::assert_class(llt, "choices_selected") |
| 400 | ! |
checkmate::assert_class(baskets, "choices_selected") |
| 401 | ! |
checkmate::assert_class(scopes, "choices_selected") |
| 402 | ! |
checkmate::assert_flag(add_total) |
| 403 | ! |
checkmate::assert_string(total_label) |
| 404 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 405 | ! |
sort_criteria <- match.arg(sort_criteria) |
| 406 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 407 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 408 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 409 | ||
| 410 | ! |
args <- as.list(environment()) |
| 411 | ||
| 412 | ! |
data_extract_list <- list( |
| 413 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 414 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 415 | ! |
baskets = cs_to_des_select(baskets, dataname = dataname, multiple = TRUE), |
| 416 | ! |
scopes = cs_to_des_select(scopes, dataname = dataname, multiple = TRUE), |
| 417 | ! |
llt = cs_to_des_select(llt, dataname = dataname) |
| 418 |
) |
|
| 419 | ||
| 420 | ! |
module( |
| 421 | ! |
label = label, |
| 422 | ! |
ui = ui_t_smq, |
| 423 | ! |
server = srv_t_smq, |
| 424 | ! |
ui_args = c(data_extract_list, args), |
| 425 | ! |
server_args = c( |
| 426 | ! |
data_extract_list, |
| 427 | ! |
list( |
| 428 | ! |
dataname = dataname, |
| 429 | ! |
parentname = parentname, |
| 430 | ! |
na_level = na_level, |
| 431 | ! |
label = label, |
| 432 | ! |
total_label = total_label, |
| 433 | ! |
basic_table_args = basic_table_args |
| 434 |
) |
|
| 435 |
), |
|
| 436 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 437 |
) |
|
| 438 |
} |
|
| 439 | ||
| 440 |
#' @keywords internal |
|
| 441 |
ui_t_smq <- function(id, ...) {
|
|
| 442 | ! |
ns <- NS(id) |
| 443 | ! |
a <- list(...) # module args |
| 444 | ||
| 445 | ||
| 446 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 447 | ! |
a$arm_var, |
| 448 | ! |
a$id_var, |
| 449 | ! |
a$baskets, |
| 450 | ! |
a$scopes, |
| 451 | ! |
a$llt |
| 452 |
) |
|
| 453 | ||
| 454 | ! |
teal.widgets::standard_layout( |
| 455 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 456 | ! |
encoding = tags$div( |
| 457 |
### Reporter |
|
| 458 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 459 |
### |
|
| 460 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 461 | ! |
teal.transform::datanames_input(a[c( |
| 462 | ! |
"arm_var", "baskets", "llt", "id_var", "scopes" |
| 463 |
)]), |
|
| 464 | ! |
teal.transform::data_extract_ui( |
| 465 | ! |
id = ns("arm_var"),
|
| 466 | ! |
label = "Select Treatment Variable", |
| 467 | ! |
data_extract_spec = a$arm_var, |
| 468 | ! |
is_single_dataset = is_single_dataset_value |
| 469 |
), |
|
| 470 | ! |
teal.transform::data_extract_ui( |
| 471 | ! |
id = ns("llt"),
|
| 472 | ! |
label = "Select the low level term", |
| 473 | ! |
data_extract_spec = a$llt, |
| 474 | ! |
is_single_dataset = is_single_dataset_value |
| 475 |
), |
|
| 476 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total),
|
| 477 | ! |
teal.transform::data_extract_ui( |
| 478 | ! |
id = ns("baskets"),
|
| 479 | ! |
label = "Select the SMQXXNAM/CQXXNAM baskets", |
| 480 | ! |
data_extract_spec = a$baskets, |
| 481 | ! |
is_single_dataset = is_single_dataset_value |
| 482 |
), |
|
| 483 | ! |
teal.widgets::panel_group( |
| 484 | ! |
teal.widgets::panel_item( |
| 485 | ! |
"Additional Variables Info", |
| 486 | ! |
checkboxInput( |
| 487 | ! |
ns( |
| 488 | ! |
"drop_arm_levels" |
| 489 |
), |
|
| 490 | ! |
"Drop arm levels not in filtered analysis dataset", |
| 491 | ! |
value = a$drop_arm_levels |
| 492 |
), |
|
| 493 | ! |
teal.transform::data_extract_ui( |
| 494 | ! |
id = ns("id_var"),
|
| 495 | ! |
label = "Subject Identifier", |
| 496 | ! |
data_extract_spec = a$id_var, |
| 497 | ! |
is_single_dataset = is_single_dataset_value |
| 498 |
), |
|
| 499 | ! |
teal.transform::data_extract_ui( |
| 500 | ! |
id = ns("scopes"),
|
| 501 | ! |
label = "Scope variables available", |
| 502 | ! |
data_extract_spec = a$scopes, |
| 503 | ! |
is_single_dataset = is_single_dataset_value |
| 504 |
), |
|
| 505 | ! |
selectInput( |
| 506 | ! |
inputId = ns("sort_criteria"),
|
| 507 | ! |
label = "Sort Criteria", |
| 508 | ! |
choices = c( |
| 509 | ! |
"Decreasing frequency" = "freq_desc", |
| 510 | ! |
"Alphabetically" = "alpha" |
| 511 |
), |
|
| 512 | ! |
selected = a$sort_criteria, |
| 513 | ! |
multiple = FALSE |
| 514 |
) |
|
| 515 |
) |
|
| 516 |
) |
|
| 517 |
), |
|
| 518 | ! |
forms = tagList( |
| 519 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 520 |
), |
|
| 521 | ! |
pre_output = a$pre_output, |
| 522 | ! |
post_output = a$post_output |
| 523 |
) |
|
| 524 |
} |
|
| 525 | ||
| 526 |
#' @keywords internal |
|
| 527 |
srv_t_smq <- function(id, |
|
| 528 |
data, |
|
| 529 |
reporter, |
|
| 530 |
filter_panel_api, |
|
| 531 |
dataname, |
|
| 532 |
parentname, |
|
| 533 |
arm_var, |
|
| 534 |
llt, |
|
| 535 |
id_var, |
|
| 536 |
baskets, |
|
| 537 |
scopes, |
|
| 538 |
na_level, |
|
| 539 |
label, |
|
| 540 |
total_label, |
|
| 541 |
basic_table_args) {
|
|
| 542 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 543 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 544 | ! |
checkmate::assert_class(data, "reactive") |
| 545 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 546 | ! |
moduleServer(id, function(input, output, session) {
|
| 547 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 548 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 549 | ! |
data_extract = list( |
| 550 | ! |
scopes = scopes, |
| 551 | ! |
llt = llt, |
| 552 | ! |
arm_var = arm_var, |
| 553 | ! |
id_var = id_var, |
| 554 | ! |
baskets = baskets |
| 555 |
), |
|
| 556 | ! |
datasets = data, |
| 557 | ! |
select_validation_rule = list( |
| 558 | ! |
scopes = shinyvalidate::sv_required("A scope variable is required"),
|
| 559 | ! |
llt = shinyvalidate::sv_required("A low level term variable is required"),
|
| 560 | ! |
arm_var = shinyvalidate::compose_rules( |
| 561 | ! |
shinyvalidate::sv_required("At least one treatment variable is required"),
|
| 562 | ! |
~ if (length(.) > 2) "Please select no more than two treatment variables" |
| 563 |
), |
|
| 564 | ! |
id_var = shinyvalidate::sv_required("An id variable is required"),
|
| 565 | ! |
baskets = shinyvalidate::sv_required("At least one basket is required")
|
| 566 |
) |
|
| 567 |
) |
|
| 568 | ||
| 569 | ! |
iv_r <- reactive({
|
| 570 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 571 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 572 |
}) |
|
| 573 | ||
| 574 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 575 | ! |
datasets = data, |
| 576 | ! |
selector_list = selector_list, |
| 577 | ! |
merge_function = "dplyr::inner_join" |
| 578 |
) |
|
| 579 | ||
| 580 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 581 | ! |
datasets = data, |
| 582 | ! |
data_extract = list(arm_var = arm_var), |
| 583 | ! |
anl_name = "ANL_ADSL" |
| 584 |
) |
|
| 585 | ||
| 586 | ! |
anl_q <- reactive({
|
| 587 | ! |
data() %>% |
| 588 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 589 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 590 |
}) |
|
| 591 | ||
| 592 | ! |
merged <- list( |
| 593 | ! |
anl_input_r = anl_inputs, |
| 594 | ! |
adsl_input_r = adsl_inputs, |
| 595 | ! |
anl_q = anl_q |
| 596 |
) |
|
| 597 | ||
| 598 | ! |
validate_checks <- reactive({
|
| 599 | ! |
teal::validate_inputs(iv_r()) |
| 600 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 601 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 602 | ||
| 603 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 604 | ! |
input_id_var <- names(merged$anl_input_r()$columns_source$id_var) |
| 605 | ! |
input_baskets <- names(merged$anl_input_r()$columns_source$baskets) |
| 606 | ! |
input_scopes <- names(merged$anl_input_r()$columns_source$scopes) |
| 607 | ! |
input_llt <- names(merged$anl_input_r()$columns_source$llt) |
| 608 | ||
| 609 |
# validate inputs |
|
| 610 | ! |
validate_standard_inputs( |
| 611 | ! |
adsl = adsl_filtered, |
| 612 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 613 | ! |
anl = anl_filtered, |
| 614 | ! |
anlvars = c( |
| 615 | ! |
"USUBJID", "STUDYID", input_id_var, input_baskets, |
| 616 | ! |
input_scopes, input_llt |
| 617 |
), |
|
| 618 | ! |
arm_var = input_arm_var[[1]] |
| 619 |
) |
|
| 620 |
}) |
|
| 621 | ||
| 622 | ! |
all_q <- reactive({
|
| 623 | ! |
validate_checks() |
| 624 | ||
| 625 | ! |
my_calls <- template_smq( |
| 626 | ! |
parentname = "ANL_ADSL", |
| 627 | ! |
dataname = "ANL", |
| 628 | ! |
arm_var = names(merged$anl_input_r()$columns_source$arm_var), |
| 629 | ! |
llt = names(merged$anl_input_r()$columns_source$llt), |
| 630 | ! |
add_total = input$add_total, |
| 631 | ! |
total_label = total_label, |
| 632 | ! |
sort_criteria = input$sort_criteria, |
| 633 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 634 | ! |
baskets = names(merged$anl_input_r()$columns_source$baskets), |
| 635 | ! |
na_level = na_level, |
| 636 | ! |
id_var = names(merged$anl_input_r()$columns_source$id_var), |
| 637 | ! |
basic_table_args = basic_table_args |
| 638 |
) |
|
| 639 | ||
| 640 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 641 |
}) |
|
| 642 | ||
| 643 |
# Outputs to render. |
|
| 644 | ! |
table_r <- reactive(all_q()[["pruned_and_sorted_result"]]) |
| 645 | ||
| 646 | ! |
teal.widgets::table_with_settings_srv( |
| 647 | ! |
id = "table", |
| 648 | ! |
table_r = table_r |
| 649 |
) |
|
| 650 | ||
| 651 |
# Render R code. |
|
| 652 | ! |
teal.widgets::verbatim_popup_srv( |
| 653 | ! |
id = "rcode", |
| 654 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 655 | ! |
title = label |
| 656 |
) |
|
| 657 | ||
| 658 |
### REPORTER |
|
| 659 | ! |
if (with_reporter) {
|
| 660 | ! |
card_fun <- function(comment, label) {
|
| 661 | ! |
card <- teal::report_card_template( |
| 662 | ! |
title = "Adverse Events Table by Standardized `MedDRA` Query (SMQ)", |
| 663 | ! |
label = label, |
| 664 | ! |
with_filter = with_filter, |
| 665 | ! |
filter_panel_api = filter_panel_api |
| 666 |
) |
|
| 667 | ! |
card$append_text("Table", "header3")
|
| 668 | ! |
card$append_table(table_r()) |
| 669 | ! |
if (!comment == "") {
|
| 670 | ! |
card$append_text("Comment", "header3")
|
| 671 | ! |
card$append_text(comment) |
| 672 |
} |
|
| 673 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 674 | ! |
card |
| 675 |
} |
|
| 676 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 677 |
} |
|
| 678 |
### |
|
| 679 |
}) |
|
| 680 |
} |
| 1 |
#' Template: Individual Patient Plots |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate [ggplot2::ggplot()] plots of individual patients. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param visit_var (`character`)\cr name of the variable for visit timepoints. |
|
| 7 |
#' @param add_baseline_hline (`logical`)\cr whether a horizontal line should be added to the plot at baseline y-value. |
|
| 8 |
#' @param separate_by_obs (`logical`)\cr whether to create multi-panel plots. |
|
| 9 |
#' @param suppress_legend (`logical`)\cr whether to suppress the plot legend. |
|
| 10 |
#' @param arm_levels (`character`)\cr vector of all levels of `arm_var`. |
|
| 11 |
#' @param avalu_first (`character`)\cr `avalu_var` text to append to the plot title and y-axis label if `add_avalu` is |
|
| 12 |
#' `TRUE`. |
|
| 13 |
#' @param paramcd_first (`character`)\cr `paramcd` text to append to the plot title and y-axis label. |
|
| 14 |
#' @param add_avalu (`logical`)\cr whether `avalu_first` text should be appended to the plot title and y-axis label. |
|
| 15 |
#' @param ggplot2_args (`ggplot2_args`) optional\cr object created by [teal.widgets::ggplot2_args()] with settings |
|
| 16 |
#' for the module plot. For this module, this argument will only accept `ggplot2_args` object with `labs` list of |
|
| 17 |
#' the following child elements: `title`, `subtitle`, `x`, `y`. No other elements are taken into account. The |
|
| 18 |
#' argument is merged with option `teal.ggplot2_args` and with default module arguments (hard coded in the module |
|
| 19 |
#' body). |
|
| 20 |
#' |
|
| 21 |
#' For more details, see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")`.
|
|
| 22 |
#' |
|
| 23 |
#' @inherit template_arguments return |
|
| 24 |
#' |
|
| 25 |
#' @seealso [tm_g_ipp()] |
|
| 26 |
#' |
|
| 27 |
#' @keywords internal |
|
| 28 |
template_g_ipp <- function(dataname = "ANL", |
|
| 29 |
paramcd, |
|
| 30 |
arm_var, |
|
| 31 |
arm_levels, |
|
| 32 |
avalu_first, |
|
| 33 |
paramcd_first, |
|
| 34 |
aval_var = "AVAL", |
|
| 35 |
avalu_var = "AVALU", |
|
| 36 |
id_var = "USUBJID", |
|
| 37 |
visit_var = "AVISIT", |
|
| 38 |
base_var = lifecycle::deprecated(), |
|
| 39 |
baseline_var = "BASE", |
|
| 40 |
add_baseline_hline = FALSE, |
|
| 41 |
separate_by_obs = FALSE, |
|
| 42 |
ggplot2_args = teal.widgets::ggplot2_args(), |
|
| 43 |
suppress_legend = FALSE, |
|
| 44 |
add_avalu = TRUE) {
|
|
| 45 | 2x |
if (lifecycle::is_present(base_var)) {
|
| 46 | ! |
baseline_var <- base_var |
| 47 | ! |
warning( |
| 48 | ! |
"The `base_var` argument of `template_g_ipp()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 49 | ! |
"Please use the `baseline_var` argument instead.", |
| 50 | ! |
call. = FALSE |
| 51 |
) |
|
| 52 |
} |
|
| 53 | ||
| 54 | 2x |
checkmate::assert_string(dataname) |
| 55 | 2x |
checkmate::assert_string(paramcd) |
| 56 | 2x |
checkmate::assert_string(arm_var) |
| 57 | 2x |
checkmate::assert_string(aval_var) |
| 58 | 2x |
checkmate::assert_string(avalu_var) |
| 59 | 2x |
checkmate::assert_string(id_var) |
| 60 | 2x |
checkmate::assert_string(visit_var) |
| 61 | 2x |
checkmate::assert_string(baseline_var) |
| 62 | 2x |
checkmate::assert_flag(add_baseline_hline) |
| 63 | 2x |
checkmate::assert_flag(separate_by_obs) |
| 64 | 2x |
checkmate::assert_flag(suppress_legend) |
| 65 | 2x |
checkmate::assert_flag(add_avalu) |
| 66 | ||
| 67 | 2x |
y <- list() |
| 68 |
# Data preprocessing |
|
| 69 | ||
| 70 | 2x |
y$data <- substitute( |
| 71 | 2x |
expr = anl <- df %>% droplevels(), |
| 72 | 2x |
env = list(df = as.name(dataname)) |
| 73 |
) |
|
| 74 | ||
| 75 | 2x |
title <- ifelse( |
| 76 | 2x |
add_avalu, |
| 77 | 2x |
sprintf("Individual Patient Plot for %s Values (%s) over Time", paramcd_first, avalu_first),
|
| 78 | 2x |
sprintf("Individual Patient Plot for %s Values over Time", paramcd_first)
|
| 79 |
) |
|
| 80 | 2x |
y_axis <- ifelse( |
| 81 | 2x |
add_avalu, |
| 82 | 2x |
sprintf("%s (%s)", paramcd_first, avalu_first),
|
| 83 | 2x |
paramcd_first |
| 84 |
) |
|
| 85 | ||
| 86 | 2x |
all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( |
| 87 | 2x |
user_plot = ggplot2_args, |
| 88 | 2x |
module_plot = teal.widgets::ggplot2_args( |
| 89 | 2x |
labs = list( |
| 90 | 2x |
title = title, |
| 91 | 2x |
x = "Visit", |
| 92 | 2x |
y = y_axis, |
| 93 | 2x |
subtitle = paste(arm_levels, collapse = ", ") |
| 94 |
) |
|
| 95 |
) |
|
| 96 |
) |
|
| 97 | ||
| 98 | 2x |
graph_list <- list() |
| 99 | 2x |
graph_list <- add_expr( |
| 100 | 2x |
graph_list, |
| 101 | 2x |
substitute( |
| 102 | 2x |
expr = {
|
| 103 | ! |
plot <- h_g_ipp( |
| 104 | ! |
df = anl, |
| 105 | ! |
xvar = visit, |
| 106 | ! |
yvar = aval, |
| 107 | ! |
xlab = xlab_val, |
| 108 | ! |
ylab = ylab_val, |
| 109 | ! |
title = title_val, |
| 110 | ! |
subtitle = subtitle_val, |
| 111 | ! |
id_var = id, |
| 112 | ! |
add_baseline_hline = add_baseline_hline, |
| 113 | ! |
yvar_baseline = base |
| 114 |
) |
|
| 115 |
}, |
|
| 116 | 2x |
env = list( |
| 117 | 2x |
xlab_val = all_ggplot2_args$labs$x, |
| 118 | 2x |
ylab_val = all_ggplot2_args$labs$y, |
| 119 | 2x |
title_val = all_ggplot2_args$labs$title, |
| 120 | 2x |
subtitle_val = all_ggplot2_args$labs$subtitle, |
| 121 | 2x |
paramcd = paramcd, |
| 122 | 2x |
visit = visit_var, |
| 123 | 2x |
aval = aval_var, |
| 124 | 2x |
id = id_var, |
| 125 | 2x |
add_baseline_hline = add_baseline_hline, |
| 126 | 2x |
base = baseline_var, |
| 127 | 2x |
avalu = avalu_var, |
| 128 | 2x |
arm = arm_var |
| 129 |
) |
|
| 130 |
) |
|
| 131 |
) |
|
| 132 | ||
| 133 | 2x |
if (separate_by_obs) {
|
| 134 | 1x |
graph_list <- add_expr( |
| 135 | 1x |
graph_list, |
| 136 | 1x |
substitute( |
| 137 | 1x |
expr = plot <- plot + ggplot2::facet_grid(rows = ggplot2::vars(id)), |
| 138 | 1x |
env = list(id = as.name(id_var)) |
| 139 |
) |
|
| 140 |
) |
|
| 141 |
} |
|
| 142 | ||
| 143 | 2x |
if (suppress_legend) {
|
| 144 | ! |
graph_list <- add_expr( |
| 145 | ! |
graph_list, |
| 146 | ! |
substitute( |
| 147 | ! |
expr = {
|
| 148 | ! |
plot <- plot + ggplot2::theme(legend.position = "none") |
| 149 |
}, |
|
| 150 | ! |
env = list(id = as.name(id_var)) |
| 151 |
) |
|
| 152 |
) |
|
| 153 |
} |
|
| 154 | ||
| 155 | 2x |
graph_list <- add_expr( |
| 156 | 2x |
graph_list, |
| 157 | 2x |
quote(grid::grid.newpage()) |
| 158 |
) |
|
| 159 | ||
| 160 | 2x |
graph_list <- add_expr( |
| 161 | 2x |
graph_list, |
| 162 | 2x |
quote(grid::grid.draw(plot)) |
| 163 |
) |
|
| 164 | ||
| 165 | 2x |
y$graph <- bracket_expr(graph_list) |
| 166 | ||
| 167 | 2x |
y |
| 168 |
} |
|
| 169 | ||
| 170 |
#' teal Module: Individual Patient Plots |
|
| 171 |
#' |
|
| 172 |
#' This module produces [ggplot2::ggplot()] type individual patient plots that display trends in parameter |
|
| 173 |
#' values over time for each patient, using data with ADaM structure. |
|
| 174 |
#' |
|
| 175 |
#' @inheritParams module_arguments |
|
| 176 |
#' @inheritParams template_g_ipp |
|
| 177 |
#' @param arm_var ([teal.transform::choices_selected()])\cr object with |
|
| 178 |
#' all available choices and preselected option for variable values that can be used as arm variable. |
|
| 179 |
#' |
|
| 180 |
#' @inherit module_arguments return seealso |
|
| 181 |
#' |
|
| 182 |
#' @examples |
|
| 183 |
#' library(nestcolor) |
|
| 184 |
#' library(dplyr) |
|
| 185 |
#' |
|
| 186 |
#' ADSL <- tmc_ex_adsl %>% |
|
| 187 |
#' slice(1:20) %>% |
|
| 188 |
#' df_explicit_na() |
|
| 189 |
#' ADLB <- tmc_ex_adlb %>% |
|
| 190 |
#' filter(USUBJID %in% ADSL$USUBJID) %>% |
|
| 191 |
#' df_explicit_na() %>% |
|
| 192 |
#' filter(AVISIT != "SCREENING") |
|
| 193 |
#' |
|
| 194 |
#' app <- init( |
|
| 195 |
#' data = cdisc_data( |
|
| 196 |
#' ADSL = ADSL, |
|
| 197 |
#' ADLB = ADLB, |
|
| 198 |
#' code = " |
|
| 199 |
#' ADSL <- tmc_ex_adsl %>% slice(1:20) %>% df_explicit_na() |
|
| 200 |
#' ADLB <- tmc_ex_adlb %>% filter(USUBJID %in% ADSL$USUBJID) %>% |
|
| 201 |
#' df_explicit_na() %>% filter(AVISIT != \"SCREENING\") |
|
| 202 |
#' " |
|
| 203 |
#' ), |
|
| 204 |
#' modules = modules( |
|
| 205 |
#' tm_g_ipp( |
|
| 206 |
#' label = "Individual Patient Plot", |
|
| 207 |
#' dataname = "ADLB", |
|
| 208 |
#' arm_var = choices_selected( |
|
| 209 |
#' value_choices(ADLB, "ARMCD"), |
|
| 210 |
#' "ARM A" |
|
| 211 |
#' ), |
|
| 212 |
#' paramcd = choices_selected( |
|
| 213 |
#' value_choices(ADLB, "PARAMCD"), |
|
| 214 |
#' "ALT" |
|
| 215 |
#' ), |
|
| 216 |
#' aval_var = choices_selected( |
|
| 217 |
#' variable_choices(ADLB, c("AVAL", "CHG")),
|
|
| 218 |
#' "AVAL" |
|
| 219 |
#' ), |
|
| 220 |
#' avalu_var = choices_selected( |
|
| 221 |
#' variable_choices(ADLB, c("AVALU")),
|
|
| 222 |
#' "AVALU", |
|
| 223 |
#' fixed = TRUE |
|
| 224 |
#' ), |
|
| 225 |
#' id_var = choices_selected( |
|
| 226 |
#' variable_choices(ADLB, c("USUBJID")),
|
|
| 227 |
#' "USUBJID", |
|
| 228 |
#' fixed = TRUE |
|
| 229 |
#' ), |
|
| 230 |
#' visit_var = choices_selected( |
|
| 231 |
#' variable_choices(ADLB, c("AVISIT")),
|
|
| 232 |
#' "AVISIT" |
|
| 233 |
#' ), |
|
| 234 |
#' baseline_var = choices_selected( |
|
| 235 |
#' variable_choices(ADLB, c("BASE")),
|
|
| 236 |
#' "BASE", |
|
| 237 |
#' fixed = TRUE |
|
| 238 |
#' ), |
|
| 239 |
#' add_baseline_hline = FALSE, |
|
| 240 |
#' separate_by_obs = FALSE |
|
| 241 |
#' ) |
|
| 242 |
#' ) |
|
| 243 |
#' ) |
|
| 244 |
#' if (interactive()) {
|
|
| 245 |
#' shinyApp(app$ui, app$server) |
|
| 246 |
#' } |
|
| 247 |
#' |
|
| 248 |
#' @export |
|
| 249 |
tm_g_ipp <- function(label, |
|
| 250 |
dataname, |
|
| 251 |
parentname = ifelse( |
|
| 252 |
inherits(arm_var, "data_extract_spec"), |
|
| 253 |
teal.transform::datanames_input(arm_var), |
|
| 254 |
"ADSL" |
|
| 255 |
), |
|
| 256 |
arm_var, |
|
| 257 |
paramcd, |
|
| 258 |
id_var = teal.transform::choices_selected( |
|
| 259 |
teal.transform::variable_choices(dataname, "USUBJID"), |
|
| 260 |
"USUBJID", |
|
| 261 |
fixed = TRUE |
|
| 262 |
), |
|
| 263 |
visit_var = teal.transform::choices_selected( |
|
| 264 |
teal.transform::variable_choices(dataname, "AVISIT"), |
|
| 265 |
"AVISIT", |
|
| 266 |
fixed = TRUE |
|
| 267 |
), |
|
| 268 |
aval_var = teal.transform::choices_selected( |
|
| 269 |
teal.transform::variable_choices(dataname, "AVAL"), |
|
| 270 |
"AVAL", |
|
| 271 |
fixed = TRUE |
|
| 272 |
), |
|
| 273 |
avalu_var = teal.transform::choices_selected( |
|
| 274 |
teal.transform::variable_choices(dataname, "AVALU"), |
|
| 275 |
"AVALU", |
|
| 276 |
fixed = TRUE |
|
| 277 |
), |
|
| 278 |
base_var = lifecycle::deprecated(), |
|
| 279 |
baseline_var = teal.transform::choices_selected( |
|
| 280 |
teal.transform::variable_choices(dataname, "BASE"), |
|
| 281 |
"BASE", |
|
| 282 |
fixed = TRUE |
|
| 283 |
), |
|
| 284 |
add_baseline_hline = FALSE, |
|
| 285 |
separate_by_obs = FALSE, |
|
| 286 |
suppress_legend = FALSE, |
|
| 287 |
add_avalu = TRUE, |
|
| 288 |
plot_height = c(1200L, 400L, 5000L), |
|
| 289 |
plot_width = NULL, |
|
| 290 |
pre_output = NULL, |
|
| 291 |
post_output = NULL, |
|
| 292 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 293 | ! |
if (lifecycle::is_present(base_var)) {
|
| 294 | ! |
baseline_var <- base_var |
| 295 | ! |
warning( |
| 296 | ! |
"The `base_var` argument of `tm_g_ipp()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 297 | ! |
"Please use the `baseline_var` argument instead.", |
| 298 | ! |
call. = FALSE |
| 299 |
) |
|
| 300 |
} else {
|
|
| 301 | ! |
base_var <- baseline_var # resolves missing argument error |
| 302 |
} |
|
| 303 | ||
| 304 | ! |
message("Initializing tm_g_ipp")
|
| 305 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 306 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 307 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 308 | ! |
checkmate::assert_class(visit_var, "choices_selected") |
| 309 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 310 | ! |
checkmate::assert_class(avalu_var, "choices_selected") |
| 311 | ! |
checkmate::assert_class(baseline_var, "choices_selected") |
| 312 | ! |
checkmate::assert_string(label) |
| 313 | ! |
checkmate::assert_string(dataname) |
| 314 | ! |
checkmate::assert_string(parentname) |
| 315 | ! |
checkmate::assert_flag(add_baseline_hline) |
| 316 | ! |
checkmate::assert_flag(separate_by_obs) |
| 317 | ! |
checkmate::assert_flag(suppress_legend) |
| 318 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 319 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 320 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 321 | ! |
checkmate::assert_numeric( |
| 322 | ! |
plot_width[1], |
| 323 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 324 |
) |
|
| 325 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 326 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 327 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 328 | ||
| 329 | ! |
args <- as.list(environment()) |
| 330 | ! |
data_extract_list <- list( |
| 331 | ! |
arm_var = cs_to_des_filter(arm_var, dataname = parentname, multiple = TRUE, include_vars = TRUE), |
| 332 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 333 | ! |
avalu_var = cs_to_des_select(avalu_var, dataname = dataname), |
| 334 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 335 | ! |
visit_var = cs_to_des_select(visit_var, dataname = dataname), |
| 336 | ! |
baseline_var = cs_to_des_select(baseline_var, dataname = dataname), |
| 337 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname) |
| 338 |
) |
|
| 339 | ||
| 340 | ! |
module( |
| 341 | ! |
label = label, |
| 342 | ! |
server = srv_g_ipp, |
| 343 | ! |
ui = ui_g_ipp, |
| 344 | ! |
ui_args = c(data_extract_list, args), |
| 345 | ! |
server_args = c( |
| 346 | ! |
data_extract_list, |
| 347 | ! |
list( |
| 348 | ! |
dataname = dataname, |
| 349 | ! |
label = label, |
| 350 | ! |
parentname = parentname, |
| 351 | ! |
plot_height = plot_height, |
| 352 | ! |
plot_width = plot_width, |
| 353 | ! |
ggplot2_args = ggplot2_args |
| 354 |
) |
|
| 355 |
), |
|
| 356 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 357 |
) |
|
| 358 |
} |
|
| 359 | ||
| 360 |
#' @keywords internal |
|
| 361 |
ui_g_ipp <- function(id, ...) {
|
|
| 362 | ! |
a <- list(...) # module args |
| 363 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 364 | ! |
a$arm_var, |
| 365 | ! |
a$aval_var, |
| 366 | ! |
a$avalu_var, |
| 367 | ! |
a$id_var, |
| 368 | ! |
a$visit_var, |
| 369 | ! |
a$paramcd, |
| 370 | ! |
a$baseline_var |
| 371 |
) |
|
| 372 | ||
| 373 | ! |
ns <- NS(id) |
| 374 | ||
| 375 | ! |
teal.widgets::standard_layout( |
| 376 | ! |
output = teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 377 | ! |
encoding = tags$div( |
| 378 |
### Reporter |
|
| 379 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 380 |
### |
|
| 381 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 382 | ! |
teal.transform::datanames_input( |
| 383 | ! |
a[c("arm_var", "aval_var", "avalu_var", "id_var", "visit_var", "paramcd", "baseline_var")]
|
| 384 |
), |
|
| 385 | ! |
teal.transform::data_extract_ui( |
| 386 | ! |
id = ns("arm_var"),
|
| 387 | ! |
label = "Select Arm", |
| 388 | ! |
data_extract_spec = a$arm_var, |
| 389 | ! |
is_single_dataset = is_single_dataset_value |
| 390 |
), |
|
| 391 | ! |
teal.transform::data_extract_ui( |
| 392 | ! |
id = ns("paramcd"),
|
| 393 | ! |
label = "Select Parameter", |
| 394 | ! |
data_extract_spec = a$paramcd, |
| 395 | ! |
is_single_dataset = is_single_dataset_value |
| 396 |
), |
|
| 397 | ! |
teal.transform::data_extract_ui( |
| 398 | ! |
id = ns("visit_var"),
|
| 399 | ! |
label = "Timepoint Variable", |
| 400 | ! |
data_extract_spec = a$visit_var, |
| 401 | ! |
is_single_dataset = is_single_dataset_value |
| 402 |
), |
|
| 403 | ! |
teal.transform::data_extract_ui( |
| 404 | ! |
id = ns("aval_var"),
|
| 405 | ! |
label = "Parameter values over Time", |
| 406 | ! |
data_extract_spec = a$aval_var, |
| 407 | ! |
is_single_dataset = is_single_dataset_value |
| 408 |
), |
|
| 409 | ! |
teal.transform::data_extract_ui( |
| 410 | ! |
id = ns("id_var"),
|
| 411 | ! |
label = "Patient ID", |
| 412 | ! |
data_extract_spec = a$id_var, |
| 413 | ! |
is_single_dataset = is_single_dataset_value |
| 414 |
), |
|
| 415 | ! |
teal.transform::data_extract_ui( |
| 416 | ! |
id = ns("avalu_var"),
|
| 417 | ! |
label = "Analysis Variable Unit", |
| 418 | ! |
data_extract_spec = a$avalu_var, |
| 419 | ! |
is_single_dataset = is_single_dataset_value |
| 420 |
), |
|
| 421 | ! |
teal.transform::data_extract_ui( |
| 422 | ! |
id = ns("baseline_var"),
|
| 423 | ! |
label = "Baseline Parameter Values", |
| 424 | ! |
data_extract_spec = a$baseline_var, |
| 425 | ! |
is_single_dataset = is_single_dataset_value |
| 426 |
), |
|
| 427 | ! |
teal.widgets::panel_group( |
| 428 | ! |
teal.widgets::panel_item( |
| 429 | ! |
"Additional plot settings", |
| 430 | ! |
checkboxInput( |
| 431 | ! |
ns("add_baseline_hline"),
|
| 432 | ! |
"Add reference lines at baseline value", |
| 433 | ! |
value = a$add_baseline_hline |
| 434 |
), |
|
| 435 | ! |
checkboxInput( |
| 436 | ! |
ns("separate_by_obs"),
|
| 437 | ! |
"Separate plots by ID", |
| 438 | ! |
value = a$separate_by_obs |
| 439 |
), |
|
| 440 | ! |
checkboxInput( |
| 441 | ! |
ns("suppress_legend"),
|
| 442 | ! |
"Suppress legend", |
| 443 | ! |
value = a$suppress_legend |
| 444 |
), |
|
| 445 | ! |
checkboxInput( |
| 446 | ! |
ns("add_avalu"),
|
| 447 | ! |
"Add unit value in title/y axis", |
| 448 | ! |
value = a$add_avalu |
| 449 |
) |
|
| 450 |
) |
|
| 451 |
) |
|
| 452 |
), |
|
| 453 | ! |
forms = tagList( |
| 454 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 455 |
), |
|
| 456 | ! |
pre_output = a$pre_output, |
| 457 | ! |
post_output = a$post_output |
| 458 |
) |
|
| 459 |
} |
|
| 460 | ||
| 461 |
#' @keywords internal |
|
| 462 |
srv_g_ipp <- function(id, |
|
| 463 |
data, |
|
| 464 |
reporter, |
|
| 465 |
filter_panel_api, |
|
| 466 |
dataname, |
|
| 467 |
parentname, |
|
| 468 |
arm_var, |
|
| 469 |
paramcd, |
|
| 470 |
aval_var, |
|
| 471 |
avalu_var, |
|
| 472 |
id_var, |
|
| 473 |
visit_var, |
|
| 474 |
baseline_var, |
|
| 475 |
plot_height, |
|
| 476 |
plot_width, |
|
| 477 |
label, |
|
| 478 |
ggplot2_args) {
|
|
| 479 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 480 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 481 | ! |
checkmate::assert_class(data, "reactive") |
| 482 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 483 | ||
| 484 | ! |
moduleServer(id, function(input, output, session) {
|
| 485 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 486 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 487 | ! |
datasets = data, |
| 488 | ! |
data_extract = list( |
| 489 | ! |
arm_var = arm_var, |
| 490 | ! |
aval_var = aval_var, |
| 491 | ! |
avalu_var = avalu_var, |
| 492 | ! |
id_var = id_var, |
| 493 | ! |
paramcd = paramcd, |
| 494 | ! |
visit_var = visit_var, |
| 495 | ! |
baseline_var = baseline_var |
| 496 |
), |
|
| 497 | ! |
select_validation_rule = list( |
| 498 | ! |
aval_var = shinyvalidate::sv_required("A Parameter values over Time must be selected"),
|
| 499 | ! |
avalu_var = shinyvalidate::sv_required("An Analysis Variable Unit must be selected"),
|
| 500 | ! |
visit_var = shinyvalidate::sv_required("A Timepoint Variable must be selected"),
|
| 501 | ! |
id_var = shinyvalidate::sv_required("A Patient ID must be selected"),
|
| 502 | ! |
baseline_var = shinyvalidate::sv_required("Baseline Parameter Values must be selected")
|
| 503 |
), |
|
| 504 | ! |
filter_validation_rule = list( |
| 505 | ! |
paramcd = shinyvalidate::sv_required(message = "Please select Parameter filter."), |
| 506 | ! |
arm_var = shinyvalidate::sv_required(message = "Please select Arm filter.") |
| 507 |
) |
|
| 508 |
) |
|
| 509 | ||
| 510 | ! |
iv_r <- reactive({
|
| 511 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 512 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 513 |
}) |
|
| 514 | ||
| 515 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 516 | ! |
datasets = data, |
| 517 | ! |
selector_list = selector_list, |
| 518 | ! |
merge_function = "dplyr::inner_join" |
| 519 |
) |
|
| 520 | ||
| 521 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 522 | ! |
datasets = data, |
| 523 | ! |
join_keys = teal.data::join_keys(data), |
| 524 | ! |
data_extract = list(arm_var = arm_var, id_var = id_var), |
| 525 | ! |
anl_name = "ANL_ADSL" |
| 526 |
) |
|
| 527 | ||
| 528 | ! |
anl_q <- reactive({
|
| 529 | ! |
data() %>% |
| 530 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 531 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 532 |
}) |
|
| 533 | ||
| 534 |
# Prepare the analysis environment (filter data, check data, populate envir). |
|
| 535 | ! |
validate_checks <- reactive({
|
| 536 | ! |
teal::validate_inputs(iv_r()) |
| 537 | ||
| 538 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 539 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 540 | ||
| 541 | ! |
anl_m <- anl_inputs() |
| 542 | ! |
input_arm_var <- unlist(arm_var$filter)["vars_selected"] |
| 543 | ! |
input_aval_var <- as.vector(anl_m$columns_source$aval_var) |
| 544 | ! |
input_avalu_var <- as.vector(anl_m$columns_source$avalu_var) |
| 545 | ! |
input_id_var <- as.vector(anl_m$columns_source$id_var) |
| 546 | ! |
input_visit_var <- as.vector(anl_m$columns_source$visit_var) |
| 547 | ! |
input_baseline_var <- as.vector(anl_m$columns_source$baseline_var) |
| 548 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 549 | ||
| 550 |
# validate inputs |
|
| 551 | ! |
validate_args <- list( |
| 552 | ! |
adsl = adsl_filtered, |
| 553 | ! |
adslvars = c("STUDYID", input_id_var, input_arm_var),
|
| 554 | ! |
anl = anl_filtered, |
| 555 | ! |
anlvars = c( |
| 556 | ! |
"STUDYID", |
| 557 | ! |
input_id_var, |
| 558 | ! |
input_arm_var, |
| 559 | ! |
input_aval_var, |
| 560 | ! |
input_avalu_var, |
| 561 | ! |
input_paramcd, |
| 562 | ! |
input_visit_var, |
| 563 | ! |
input_baseline_var |
| 564 |
), |
|
| 565 | ! |
arm_var = input_arm_var |
| 566 |
) |
|
| 567 | ||
| 568 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 569 | ! |
NULL |
| 570 |
}) |
|
| 571 | ||
| 572 |
# The R-code corresponding to the analysis. |
|
| 573 | ! |
all_q <- reactive({
|
| 574 | ! |
validate_checks() |
| 575 | ! |
anl_m <- anl_inputs() |
| 576 | ||
| 577 | ! |
ANL <- anl_q()[["ANL"]] |
| 578 | ! |
teal::validate_has_data(ANL, 2) |
| 579 | ||
| 580 | ! |
arm_var <- unlist(arm_var$filter)["vars_selected"] |
| 581 | ! |
avalu_var <- as.vector(anl_m$columns_source$avalu_var) |
| 582 | ! |
paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 583 | ||
| 584 | ! |
avalu_first <- as.character(ANL[[avalu_var]][1]) |
| 585 | ! |
paramcd_first <- as.character(ANL[[paramcd]][1]) |
| 586 | ! |
arm_levels <- levels(droplevels(ANL[[arm_var]])) |
| 587 | ||
| 588 | ! |
my_calls <- template_g_ipp( |
| 589 | ! |
dataname = "ANL", |
| 590 | ! |
aval_var = as.vector(anl_m$columns_source$aval_var), |
| 591 | ! |
avalu_var = avalu_var, |
| 592 | ! |
avalu_first = avalu_first, |
| 593 | ! |
id_var = as.vector(anl_m$columns_source$id_var), |
| 594 | ! |
visit_var = as.vector(anl_m$columns_source$visit_var), |
| 595 | ! |
baseline_var = as.vector(anl_m$columns_source$baseline_var), |
| 596 | ! |
add_baseline_hline = input$add_baseline_hline, |
| 597 | ! |
separate_by_obs = input$separate_by_obs, |
| 598 | ! |
suppress_legend = input$suppress_legend, |
| 599 | ! |
paramcd = paramcd, |
| 600 | ! |
paramcd_first = paramcd_first, |
| 601 | ! |
arm_var = arm_var, |
| 602 | ! |
arm_levels = arm_levels, |
| 603 | ! |
ggplot2_args = ggplot2_args, |
| 604 | ! |
add_avalu = input$add_avalu |
| 605 |
) |
|
| 606 | ! |
teal.code::eval_code(anl_q(), as.expression(my_calls)) |
| 607 |
}) |
|
| 608 | ||
| 609 |
# Outputs to render. |
|
| 610 | ! |
plot_r <- reactive(all_q()[["plot"]]) |
| 611 | ||
| 612 |
# Insert the plot into a plot with settings module from teal.widgets |
|
| 613 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 614 | ! |
id = "myplot", |
| 615 | ! |
plot_r = plot_r, |
| 616 | ! |
height = plot_height, |
| 617 | ! |
width = plot_width |
| 618 |
) |
|
| 619 | ||
| 620 | ! |
teal.widgets::verbatim_popup_srv( |
| 621 | ! |
id = "rcode", |
| 622 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 623 | ! |
title = label |
| 624 |
) |
|
| 625 | ||
| 626 |
### REPORTER |
|
| 627 | ! |
if (with_reporter) {
|
| 628 | ! |
card_fun <- function(comment, label) {
|
| 629 | ! |
card <- teal::report_card_template( |
| 630 | ! |
title = "Individual Patient Plot", |
| 631 | ! |
label = label, |
| 632 | ! |
with_filter = with_filter, |
| 633 | ! |
filter_panel_api = filter_panel_api |
| 634 |
) |
|
| 635 | ! |
card$append_text("Plot", "header3")
|
| 636 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 637 | ! |
if (!comment == "") {
|
| 638 | ! |
card$append_text("Comment", "header3")
|
| 639 | ! |
card$append_text(comment) |
| 640 |
} |
|
| 641 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 642 | ! |
card |
| 643 |
} |
|
| 644 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 645 |
} |
|
| 646 |
### |
|
| 647 |
}) |
|
| 648 |
} |
| 1 |
#' Template: Confidence Interval Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a [ggplot2::ggplot()] confidence interval plot. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param x_var (`character`)\cr name of the treatment variable to put on the x-axis. |
|
| 7 |
#' @param y_var (`character`)\cr name of the response variable to put on the y-axis. |
|
| 8 |
#' @param grp_var (`character`)\cr name of the group variable used to determine the plot colors, point shapes, |
|
| 9 |
#' and line types. |
|
| 10 |
#' @param stat (`character`)\cr statistic to plot. Options are `"mean"` and `"median"`. |
|
| 11 |
#' @param unit_var (`character`)\cr name of the unit variable. |
|
| 12 |
#' |
|
| 13 |
#' @inherit template_arguments return |
|
| 14 |
#' |
|
| 15 |
#' @seealso [tm_g_ci()] |
|
| 16 |
#' |
|
| 17 |
#' @keywords internal |
|
| 18 |
template_g_ci <- function(dataname, |
|
| 19 |
x_var, |
|
| 20 |
y_var, |
|
| 21 |
grp_var = NULL, |
|
| 22 |
stat = c("mean", "median"),
|
|
| 23 |
conf_level = 0.95, |
|
| 24 |
unit_var = "AVALU", |
|
| 25 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 26 | 4x |
stat <- match.arg(stat) |
| 27 | ||
| 28 | 4x |
graph_list <- list() |
| 29 | 4x |
graph_list <- if (is.null(grp_var)) {
|
| 30 | ! |
add_expr( |
| 31 | ! |
expr_ls = graph_list, |
| 32 | ! |
new_expr = {
|
| 33 | ! |
substitute( |
| 34 | ! |
expr = ggplot2::ggplot( |
| 35 | ! |
data = ANL, |
| 36 | ! |
mapping = ggplot2::aes( |
| 37 | ! |
x = x_var, |
| 38 | ! |
y = y_var |
| 39 |
) |
|
| 40 |
), |
|
| 41 | ! |
env = list( |
| 42 | ! |
x_var = as.name(x_var), |
| 43 | ! |
y_var = as.name(y_var) |
| 44 |
) |
|
| 45 |
) |
|
| 46 |
} |
|
| 47 |
) |
|
| 48 |
} else {
|
|
| 49 | 4x |
add_expr( |
| 50 | 4x |
expr_ls = graph_list, |
| 51 | 4x |
new_expr = {
|
| 52 | 4x |
substitute( |
| 53 | 4x |
expr = ggplot2::ggplot( |
| 54 | 4x |
data = ANL, |
| 55 | 4x |
mapping = ggplot2::aes( |
| 56 | 4x |
x = x_var, |
| 57 | 4x |
y = y_var, |
| 58 | 4x |
color = grp_var, |
| 59 | 4x |
lty = grp_var, |
| 60 | 4x |
shape = grp_var |
| 61 |
) |
|
| 62 |
), |
|
| 63 | 4x |
env = list( |
| 64 | 4x |
x_var = as.name(x_var), |
| 65 | 4x |
y_var = as.name(y_var), |
| 66 | 4x |
grp_var = as.name(grp_var) |
| 67 |
) |
|
| 68 |
) |
|
| 69 |
} |
|
| 70 |
) |
|
| 71 |
} |
|
| 72 | ||
| 73 | 4x |
graph_list <- if (conf_level == 0.95) {
|
| 74 | 3x |
add_expr( |
| 75 | 3x |
expr_ls = graph_list, |
| 76 | 3x |
new_expr = substitute( |
| 77 | 3x |
expr = ggplot2::stat_summary( |
| 78 | 3x |
fun.data = fun, |
| 79 | 3x |
geom = "errorbar", |
| 80 | 3x |
width = .1, |
| 81 | 3x |
position = ggplot2::position_dodge(width = .5) |
| 82 |
), |
|
| 83 | 3x |
env = list( |
| 84 | 3x |
fun = switch(stat, |
| 85 | 3x |
mean = substitute(stat_mean_ci), |
| 86 | 3x |
median = substitute(stat_median_ci) |
| 87 |
) |
|
| 88 |
) |
|
| 89 |
) |
|
| 90 |
) |
|
| 91 |
} else {
|
|
| 92 | 1x |
add_expr( |
| 93 | 1x |
expr_ls = graph_list, |
| 94 | 1x |
new_expr = substitute( |
| 95 | 1x |
expr = ggplot2::stat_summary( |
| 96 | 1x |
fun.data = fun, |
| 97 | 1x |
geom = "errorbar", |
| 98 | 1x |
width = .1, |
| 99 | 1x |
position = ggplot2::position_dodge(width = .5) |
| 100 |
), |
|
| 101 | 1x |
env = list( |
| 102 | 1x |
fun = switch(stat, |
| 103 | 1x |
mean = substitute( |
| 104 | 1x |
expr = function(x) stat_mean_ci(x, conf_level = conf_level), |
| 105 | 1x |
env = list(conf_level = conf_level) |
| 106 |
), |
|
| 107 | 1x |
median = substitute( |
| 108 | 1x |
expr = function(x) stat_median_ci(x, conf_level = conf_level), |
| 109 | 1x |
env = list(conf_level = conf_level) |
| 110 |
) |
|
| 111 |
) |
|
| 112 |
) |
|
| 113 |
) |
|
| 114 |
) |
|
| 115 |
} |
|
| 116 | ||
| 117 | 4x |
graph_list <- add_expr( |
| 118 | 4x |
expr_ls = graph_list, |
| 119 | 4x |
new_expr = substitute( |
| 120 | 4x |
expr = ggplot2::stat_summary( |
| 121 | 4x |
fun = fun, |
| 122 | 4x |
geom = "point", |
| 123 | 4x |
position = ggplot2::position_dodge(width = .5) |
| 124 |
), |
|
| 125 | 4x |
env = list( |
| 126 | 4x |
fun = switch(stat, |
| 127 | 4x |
mean = quote(mean), |
| 128 | 4x |
median = quote(median) |
| 129 |
) |
|
| 130 |
) |
|
| 131 |
) |
|
| 132 |
) |
|
| 133 | ||
| 134 | 4x |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 135 | 4x |
teal.widgets::resolve_ggplot2_args( |
| 136 | 4x |
user_plot = ggplot2_args, |
| 137 | 4x |
module_plot = teal.widgets::ggplot2_args( |
| 138 | 4x |
labs = list( |
| 139 | 4x |
title = "Confidence Interval Plot by Treatment Group", |
| 140 | 4x |
caption = sprintf( |
| 141 | 4x |
"%s and %i%% CIs for %s are displayed.", |
| 142 | 4x |
switch(stat, |
| 143 | 4x |
mean = "Mean", |
| 144 | 4x |
median = "Median" |
| 145 |
), |
|
| 146 | 4x |
100 * conf_level, |
| 147 | 4x |
stat |
| 148 |
), |
|
| 149 | 4x |
x = "Treatment Group", |
| 150 | 4x |
y = "Value", |
| 151 | 4x |
color = "", |
| 152 | 4x |
lty = "", |
| 153 | 4x |
shape = "" |
| 154 |
), |
|
| 155 | 4x |
theme = list() |
| 156 |
) |
|
| 157 |
) |
|
| 158 |
) |
|
| 159 | ||
| 160 | 4x |
graph_list <- add_expr( |
| 161 | 4x |
expr_ls = graph_list, |
| 162 | 4x |
new_expr = parsed_ggplot2_args$labs |
| 163 |
) |
|
| 164 | ||
| 165 | 4x |
if (!is.null(parsed_ggplot2_args$theme)) {
|
| 166 | ! |
graph_list <- add_expr( |
| 167 | ! |
expr_ls = graph_list, |
| 168 | ! |
new_expr = parsed_ggplot2_args$theme |
| 169 |
) |
|
| 170 |
} |
|
| 171 | ||
| 172 | 4x |
substitute( |
| 173 | 4x |
expr = {
|
| 174 | ! |
gg <- graph_expr |
| 175 | ! |
print(gg) |
| 176 |
}, |
|
| 177 | 4x |
env = list(graph_expr = pipe_expr(graph_list, pipe_str = "+")) |
| 178 |
) |
|
| 179 |
} |
|
| 180 | ||
| 181 |
#' teal Module: Confidence Interval Plot |
|
| 182 |
#' |
|
| 183 |
#' This module produces a [ggplot2::ggplot()] type confidence interval plot consistent with the TLG Catalog template |
|
| 184 |
#' `CIG01` available [here](https://insightsengineering.github.io/tlg-catalog/stable/graphs/other/cig01.html). |
|
| 185 |
#' |
|
| 186 |
#' @inheritParams module_arguments |
|
| 187 |
#' @inheritParams template_g_ci |
|
| 188 |
#' @param color (`data_extract_spec`)\cr the group variable used to determine the plot colors, shapes, and line types. |
|
| 189 |
#' |
|
| 190 |
#' @inherit module_arguments return seealso |
|
| 191 |
#' |
|
| 192 |
#' @examples |
|
| 193 |
#' library(nestcolor) |
|
| 194 |
#' |
|
| 195 |
#' ADSL <- tmc_ex_adsl |
|
| 196 |
#' ADLB <- tmc_ex_adlb |
|
| 197 |
#' |
|
| 198 |
#' app <- init( |
|
| 199 |
#' data = cdisc_data( |
|
| 200 |
#' ADSL = ADSL, |
|
| 201 |
#' ADLB = ADLB, |
|
| 202 |
#' code = " |
|
| 203 |
#' ADSL <- tmc_ex_adsl |
|
| 204 |
#' ADLB <- tmc_ex_adlb |
|
| 205 |
#' " |
|
| 206 |
#' ), |
|
| 207 |
#' modules = modules( |
|
| 208 |
#' tm_g_ci( |
|
| 209 |
#' label = "Confidence Interval Plot", |
|
| 210 |
#' x_var = data_extract_spec( |
|
| 211 |
#' dataname = "ADSL", |
|
| 212 |
#' select = select_spec( |
|
| 213 |
#' choices = c("ARMCD", "BMRKR2"),
|
|
| 214 |
#' selected = c("ARMCD"),
|
|
| 215 |
#' multiple = FALSE, |
|
| 216 |
#' fixed = FALSE |
|
| 217 |
#' ) |
|
| 218 |
#' ), |
|
| 219 |
#' y_var = data_extract_spec( |
|
| 220 |
#' dataname = "ADLB", |
|
| 221 |
#' filter = list( |
|
| 222 |
#' filter_spec( |
|
| 223 |
#' vars = "PARAMCD", |
|
| 224 |
#' choices = levels(ADLB$PARAMCD), |
|
| 225 |
#' selected = levels(ADLB$PARAMCD)[1], |
|
| 226 |
#' multiple = FALSE, |
|
| 227 |
#' label = "Select lab:" |
|
| 228 |
#' ), |
|
| 229 |
#' filter_spec( |
|
| 230 |
#' vars = "AVISIT", |
|
| 231 |
#' choices = levels(ADLB$AVISIT), |
|
| 232 |
#' selected = levels(ADLB$AVISIT)[1], |
|
| 233 |
#' multiple = FALSE, |
|
| 234 |
#' label = "Select visit:" |
|
| 235 |
#' ) |
|
| 236 |
#' ), |
|
| 237 |
#' select = select_spec( |
|
| 238 |
#' label = "Analyzed Value", |
|
| 239 |
#' choices = c("AVAL", "CHG"),
|
|
| 240 |
#' selected = "AVAL", |
|
| 241 |
#' multiple = FALSE, |
|
| 242 |
#' fixed = FALSE |
|
| 243 |
#' ) |
|
| 244 |
#' ), |
|
| 245 |
#' color = data_extract_spec( |
|
| 246 |
#' dataname = "ADSL", |
|
| 247 |
#' select = select_spec( |
|
| 248 |
#' label = "Color by variable", |
|
| 249 |
#' choices = c("SEX", "STRATA1", "STRATA2"),
|
|
| 250 |
#' selected = c("STRATA1"),
|
|
| 251 |
#' multiple = FALSE, |
|
| 252 |
#' fixed = FALSE |
|
| 253 |
#' ) |
|
| 254 |
#' ) |
|
| 255 |
#' ) |
|
| 256 |
#' ), |
|
| 257 |
#' header = "Example of Confidence Interval Plot", |
|
| 258 |
#' footer = tags$p( |
|
| 259 |
#' class = "text-muted", "Source: `teal.modules.clinical::tm_g_ci`" |
|
| 260 |
#' ) |
|
| 261 |
#' ) |
|
| 262 |
#' if (interactive()) {
|
|
| 263 |
#' shinyApp(app$ui, app$server) |
|
| 264 |
#' } |
|
| 265 |
#' |
|
| 266 |
#' @export |
|
| 267 |
tm_g_ci <- function(label, |
|
| 268 |
x_var, |
|
| 269 |
y_var, |
|
| 270 |
color, |
|
| 271 |
stat = c("mean", "median"),
|
|
| 272 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 273 |
plot_height = c(700L, 200L, 2000L), |
|
| 274 |
plot_width = NULL, |
|
| 275 |
pre_output = NULL, |
|
| 276 |
post_output = NULL, |
|
| 277 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 278 | ! |
message("Initializing tm_g_ci")
|
| 279 | ! |
checkmate::assert_string(label) |
| 280 | ! |
stat <- match.arg(stat) |
| 281 | ! |
checkmate::assert_class(y_var, classes = "data_extract_spec") |
| 282 | ! |
checkmate::assert_class(x_var, classes = "data_extract_spec") |
| 283 | ! |
checkmate::assert_class(color, classes = "data_extract_spec") |
| 284 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 285 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 286 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 287 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 288 | ! |
checkmate::assert_numeric( |
| 289 | ! |
plot_width[1], |
| 290 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 291 |
) |
|
| 292 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 293 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 294 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 295 | ||
| 296 | ! |
args <- as.list(environment()) |
| 297 | ||
| 298 | ! |
module( |
| 299 | ! |
label = label, |
| 300 | ! |
server = srv_g_ci, |
| 301 | ! |
server_args = list( |
| 302 | ! |
x_var = x_var, |
| 303 | ! |
y_var = y_var, |
| 304 | ! |
color = color, |
| 305 | ! |
label = label, |
| 306 | ! |
plot_height = plot_height, |
| 307 | ! |
plot_width = plot_width, |
| 308 | ! |
ggplot2_args = ggplot2_args |
| 309 |
), |
|
| 310 | ! |
ui = ui_g_ci, |
| 311 | ! |
ui_args = args, |
| 312 | ! |
datanames = "all" |
| 313 |
) |
|
| 314 |
} |
|
| 315 | ||
| 316 |
#' @keywords internal |
|
| 317 |
ui_g_ci <- function(id, ...) {
|
|
| 318 | ! |
ns <- NS(id) |
| 319 | ! |
args <- list(...) |
| 320 | ||
| 321 | ! |
teal.widgets::standard_layout( |
| 322 | ! |
output = teal.widgets::plot_with_settings_ui(id = ns("myplot")),
|
| 323 | ! |
encoding = tags$div( |
| 324 |
### Reporter |
|
| 325 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 326 |
### |
|
| 327 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 328 | ! |
teal.transform::datanames_input(args[c("x_var", "y_var", "color")]),
|
| 329 | ! |
teal.transform::data_extract_ui( |
| 330 | ! |
id = ns("x_var"),
|
| 331 | ! |
label = "Treatment (x axis)", |
| 332 | ! |
data_extract_spec = args$x_var |
| 333 |
), |
|
| 334 | ! |
teal.transform::data_extract_ui( |
| 335 | ! |
id = ns("y_var"),
|
| 336 | ! |
label = "Analysis Value (y axis)", |
| 337 | ! |
data_extract_spec = args$y_var |
| 338 |
), |
|
| 339 | ! |
teal.transform::data_extract_ui( |
| 340 | ! |
id = ns("color"),
|
| 341 | ! |
label = "Groups (color)", |
| 342 | ! |
data_extract_spec = args$color |
| 343 |
), |
|
| 344 | ! |
teal.widgets::optionalSelectInput( |
| 345 | ! |
inputId = ns("conf_level"),
|
| 346 | ! |
label = "Confidence Level", |
| 347 | ! |
choices = args$conf_level$choices, |
| 348 | ! |
selected = args$conf_level$selected, |
| 349 | ! |
multiple = FALSE, |
| 350 | ! |
fixed = args$conf_level$fixed |
| 351 |
), |
|
| 352 | ! |
radioButtons( |
| 353 | ! |
inputId = ns("stat"),
|
| 354 | ! |
label = "Statistic to use", |
| 355 | ! |
choices = c("mean", "median"),
|
| 356 | ! |
selected = args$stat |
| 357 |
) |
|
| 358 |
), |
|
| 359 | ! |
forms = tagList( |
| 360 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code")
|
| 361 |
), |
|
| 362 | ! |
pre_output = args$pre_output, |
| 363 | ! |
post_output = args$post_output |
| 364 |
) |
|
| 365 |
} |
|
| 366 | ||
| 367 |
#' @keywords internal |
|
| 368 |
srv_g_ci <- function(id, |
|
| 369 |
data, |
|
| 370 |
reporter, |
|
| 371 |
filter_panel_api, |
|
| 372 |
x_var, |
|
| 373 |
y_var, |
|
| 374 |
color, |
|
| 375 |
label, |
|
| 376 |
plot_height, |
|
| 377 |
plot_width, |
|
| 378 |
ggplot2_args) {
|
|
| 379 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 380 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 381 | ! |
checkmate::assert_class(data, "reactive") |
| 382 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 383 | ||
| 384 | ! |
moduleServer(id, function(input, output, session) {
|
| 385 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 386 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 387 | ! |
data_extract = list(x_var = x_var, y_var = y_var, color = color), |
| 388 | ! |
datasets = data, |
| 389 | ! |
select_validation_rule = list( |
| 390 | ! |
x_var = shinyvalidate::sv_required("Select a treatment (x axis)"),
|
| 391 | ! |
y_var = shinyvalidate::sv_required("Select an analysis value (y axis)")
|
| 392 |
), |
|
| 393 | ! |
filter_validation_rule = list( |
| 394 | ! |
y_var = shinyvalidate::sv_required(message = "Please select the filters.") |
| 395 |
) |
|
| 396 |
) |
|
| 397 | ||
| 398 | ! |
iv_r <- reactive({
|
| 399 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 400 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level"))
|
| 401 | ! |
iv$add_rule( |
| 402 | ! |
"conf_level", |
| 403 | ! |
shinyvalidate::sv_between(0, 1, message_fmt = "Please choose a confidence level between 0 and 1") |
| 404 |
) |
|
| 405 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 406 |
}) |
|
| 407 | ||
| 408 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 409 | ! |
datasets = data, |
| 410 | ! |
join_keys = teal.data::join_keys(data), |
| 411 | ! |
selector_list = selector_list |
| 412 |
) |
|
| 413 | ||
| 414 | ! |
anl_q <- reactive({
|
| 415 | ! |
data() %>% |
| 416 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 417 |
}) |
|
| 418 | ||
| 419 | ! |
all_q <- reactive({
|
| 420 | ! |
teal::validate_inputs(iv_r()) |
| 421 | ! |
teal::validate_has_data(anl_q()[["ANL"]], min_nrow = 2) |
| 422 | ||
| 423 | ! |
x <- anl_inputs()$columns_source$x_var |
| 424 | ! |
y <- anl_inputs()$columns_source$y_var |
| 425 | ! |
color <- anl_inputs()$columns_source$color |
| 426 | ||
| 427 | ! |
validate( |
| 428 | ! |
need( |
| 429 | ! |
!all(is.na(anl_q()[["ANL"]][[y]])), |
| 430 | ! |
"No valid data. Please check the filtering option for analysis value (y axis)" |
| 431 |
) |
|
| 432 |
) |
|
| 433 | ||
| 434 | ! |
x_label <- column_annotation_label(data()[[attr(x, "dataname")]], x) |
| 435 | ! |
y_label <- column_annotation_label(data()[[attr(y, "dataname")]], y) |
| 436 | ! |
color_label <- if (length(color)) {
|
| 437 | ! |
column_annotation_label(data()[[attr(color, "dataname")]], color) |
| 438 |
} else {
|
|
| 439 | ! |
NULL |
| 440 |
} |
|
| 441 | ||
| 442 | ! |
ggplot2_args$labs$title <- paste("Confidence Interval Plot by", x_label)
|
| 443 | ! |
ggplot2_args$labs$x <- x_label |
| 444 | ! |
ggplot2_args$labs$subtitle <- paste("Visit:", anl_inputs()$filter_info$y_var[[2]]$selected[[1]])
|
| 445 | ! |
ggplot2_args$labs$y <- paste( |
| 446 | ! |
anl_inputs()$filter_info$y_var[[1]]$selected[[1]], |
| 447 | ! |
y_label |
| 448 |
) |
|
| 449 | ! |
ggplot2_args$labs$color <- color_label |
| 450 | ! |
ggplot2_args$labs$lty <- color_label |
| 451 | ! |
ggplot2_args$labs$shape <- color_label |
| 452 | ! |
list_calls <- template_g_ci( |
| 453 | ! |
dataname = "ANL", |
| 454 | ! |
x_var = x, |
| 455 | ! |
y_var = y, |
| 456 | ! |
grp_var = if (length(color) == 0) {
|
| 457 | ! |
NULL |
| 458 |
} else {
|
|
| 459 | ! |
color |
| 460 |
}, |
|
| 461 | ! |
stat = input$stat, |
| 462 | ! |
conf_level = as.numeric(input$conf_level), |
| 463 | ! |
ggplot2_args = ggplot2_args |
| 464 |
) |
|
| 465 | ! |
teal.code::eval_code(anl_q(), list_calls) |
| 466 |
}) |
|
| 467 | ||
| 468 | ! |
plot_r <- reactive(all_q()[["gg"]]) |
| 469 | ||
| 470 | ! |
teal.widgets::verbatim_popup_srv( |
| 471 | ! |
id = "rcode", |
| 472 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 473 | ! |
title = label |
| 474 |
) |
|
| 475 | ||
| 476 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 477 | ! |
id = "myplot", |
| 478 | ! |
plot_r = plot_r, |
| 479 | ! |
height = plot_height, |
| 480 | ! |
width = plot_width |
| 481 |
) |
|
| 482 | ||
| 483 |
### REPORTER |
|
| 484 | ! |
if (with_reporter) {
|
| 485 | ! |
card_fun <- function(comment, label) {
|
| 486 | ! |
card <- teal::report_card_template( |
| 487 | ! |
title = "CI Plot", |
| 488 | ! |
label = label, |
| 489 | ! |
description = "Confidence Interval Plot", |
| 490 | ! |
with_filter = with_filter, |
| 491 | ! |
filter_panel_api = filter_panel_api |
| 492 |
) |
|
| 493 | ! |
card$append_text("Plot", "header3")
|
| 494 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 495 | ! |
if (!comment == "") {
|
| 496 | ! |
card$append_text("Comment", "header3")
|
| 497 | ! |
card$append_text(comment) |
| 498 |
} |
|
| 499 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 500 | ! |
card |
| 501 |
} |
|
| 502 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 503 |
} |
|
| 504 |
### |
|
| 505 |
}) |
|
| 506 |
} |
| 1 |
#' Template: Laboratory test results with highest grade post-baseline |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table to summarize abnormality by grade. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param atoxgr_var (`character`)\cr name of the variable indicating |
|
| 7 |
#' Analysis Toxicity Grade. |
|
| 8 |
#' @param worst_high_flag_var (`character`)\cr name of the variable indicating |
|
| 9 |
#' Worst High Grade flag |
|
| 10 |
#' @param worst_low_flag_var (`character`)\cr name of the variable indicating |
|
| 11 |
#' Worst Low Grade flag |
|
| 12 |
#' @param worst_flag_indicator (`character`)\cr flag value indicating the worst grade. |
|
| 13 |
#' |
|
| 14 |
#' @inherit template_arguments return |
|
| 15 |
#' |
|
| 16 |
#' @seealso [tm_t_abnormality_by_worst_grade()] |
|
| 17 |
#' @keywords internal |
|
| 18 |
template_abnormality_by_worst_grade <- function(parentname, # nolint: object_length. |
|
| 19 |
dataname, |
|
| 20 |
arm_var, |
|
| 21 |
id_var = "USUBJID", |
|
| 22 |
paramcd = "PARAMCD", |
|
| 23 |
atoxgr_var = "ATOXGR", |
|
| 24 |
worst_high_flag_var = "WGRHIFL", |
|
| 25 |
worst_low_flag_var = "WGRLOFL", |
|
| 26 |
worst_flag_indicator = "Y", |
|
| 27 |
add_total = FALSE, |
|
| 28 |
total_label = default_total_label(), |
|
| 29 |
drop_arm_levels = TRUE, |
|
| 30 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 31 | 3x |
checkmate::assert_string(dataname) |
| 32 | 3x |
checkmate::assert_string(parentname) |
| 33 | 3x |
checkmate::assert_string(arm_var) |
| 34 | 3x |
checkmate::assert_string(id_var) |
| 35 | 3x |
checkmate::assert_string(paramcd) |
| 36 | 3x |
checkmate::assert_string(atoxgr_var) |
| 37 | 3x |
checkmate::assert_string(worst_high_flag_var) |
| 38 | 3x |
checkmate::assert_string(worst_low_flag_var) |
| 39 | 3x |
checkmate::assert_string(worst_flag_indicator) |
| 40 | 3x |
checkmate::assert_flag(add_total) |
| 41 | 3x |
checkmate::assert_string(total_label) |
| 42 | 3x |
checkmate::assert_flag(drop_arm_levels) |
| 43 | ||
| 44 | 3x |
y <- list() |
| 45 | ||
| 46 | 3x |
data_list <- list() |
| 47 | ||
| 48 | 3x |
data_list <- add_expr( |
| 49 | 3x |
data_list, |
| 50 | 3x |
substitute( |
| 51 | 3x |
expr = anl_labels <- teal.data::col_labels(df, fill = FALSE), |
| 52 | 3x |
env = list( |
| 53 | 3x |
df = as.name(dataname) |
| 54 |
) |
|
| 55 |
) |
|
| 56 |
) |
|
| 57 | ||
| 58 | 3x |
data_list <- add_expr( |
| 59 | 3x |
data_list, |
| 60 | 3x |
substitute( |
| 61 | 3x |
expr = anl <- df %>% |
| 62 | 3x |
dplyr::mutate( |
| 63 |
# Changed the following prepo step methodology as not |
|
| 64 |
# all cases have grade = 4 (realized with nsdl real data) |
|
| 65 | 3x |
GRADE_DIR = factor( |
| 66 | 3x |
dplyr::case_when( |
| 67 | 3x |
as.numeric(as.character(atoxgr_var)) < 0 ~ "LOW", |
| 68 | 3x |
atoxgr_var == "0" ~ "ZERO", |
| 69 | 3x |
as.numeric(as.character(atoxgr_var)) > 0 ~ "HIGH" |
| 70 |
), |
|
| 71 | 3x |
levels = c("LOW", "ZERO", "HIGH")
|
| 72 |
), |
|
| 73 |
# Changed the following prepo step methodology as not |
|
| 74 |
# all cases have grade = 4 (realized with nsdl real data) |
|
| 75 | 3x |
GRADE_ANL = factor( |
| 76 | 3x |
abs( |
| 77 | 3x |
as.numeric( |
| 78 | 3x |
as.character(atoxgr_var) |
| 79 |
) |
|
| 80 |
) |
|
| 81 |
) |
|
| 82 |
) %>% |
|
| 83 | 3x |
dplyr::filter(worst_low_flag_var == worst_flag_indicator | worst_high_flag_var == worst_flag_indicator) %>% |
| 84 | 3x |
droplevels(), |
| 85 | 3x |
env = list( |
| 86 | 3x |
df = as.name(dataname), |
| 87 | 3x |
worst_low_flag_var = as.name(worst_low_flag_var), |
| 88 | 3x |
worst_high_flag_var = as.name(worst_high_flag_var), |
| 89 | 3x |
worst_flag_indicator = worst_flag_indicator, |
| 90 | 3x |
atoxgr_var = as.name(atoxgr_var) |
| 91 |
) |
|
| 92 |
) |
|
| 93 |
) |
|
| 94 | ||
| 95 | 3x |
data_list <- add_expr( |
| 96 | 3x |
data_list, |
| 97 | 3x |
quote( |
| 98 | 3x |
expr = teal.data::col_labels(anl) <- c( |
| 99 | 3x |
anl_labels, |
| 100 | 3x |
GRADE_DIR = " Direction of Abnormality", |
| 101 | 3x |
GRADE_ANL = "Highest Grade" |
| 102 |
) |
|
| 103 |
) |
|
| 104 |
) |
|
| 105 | ||
| 106 | 3x |
data_list <- add_expr( |
| 107 | 3x |
data_list, |
| 108 | 3x |
prepare_arm_levels( |
| 109 | 3x |
dataname = "anl", |
| 110 | 3x |
parentname = parentname, |
| 111 | 3x |
arm_var = arm_var, |
| 112 | 3x |
drop_arm_levels = drop_arm_levels |
| 113 |
) |
|
| 114 |
) |
|
| 115 | ||
| 116 | 3x |
data_list <- add_expr( |
| 117 | 3x |
data_list, |
| 118 | 3x |
substitute( |
| 119 | 3x |
expr = if (is.null(obj_label(anl[[paramcd]]))) {
|
| 120 | ! |
stop("Please specify label for ", paramcd)
|
| 121 |
}, |
|
| 122 | 3x |
env = list( |
| 123 | 3x |
paramcd = paramcd |
| 124 |
) |
|
| 125 |
) |
|
| 126 |
) |
|
| 127 | ||
| 128 | 3x |
y$data <- bracket_expr(data_list) |
| 129 | ||
| 130 |
# map creation |
|
| 131 | ||
| 132 | 3x |
prep_list <- list() |
| 133 | ||
| 134 | 3x |
prep_list <- add_expr( |
| 135 | 3x |
prep_list, |
| 136 | 3x |
substitute( |
| 137 | 3x |
expr = map <- expand.grid( |
| 138 | 3x |
PARAM = levels(anl[[paramcd]]), |
| 139 | 3x |
GRADE_DIR = c("LOW", "HIGH"),
|
| 140 | 3x |
GRADE_ANL = as.character(1:4), |
| 141 | 3x |
stringsAsFactors = FALSE |
| 142 |
) %>% |
|
| 143 | 3x |
dplyr::arrange(paramcd, desc(GRADE_DIR), GRADE_ANL), |
| 144 | 3x |
env = list( |
| 145 | 3x |
paramcd = paramcd |
| 146 |
) |
|
| 147 |
) |
|
| 148 |
) |
|
| 149 | ||
| 150 | 3x |
y$layout_prep <- bracket_expr(prep_list) |
| 151 | ||
| 152 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 153 | 3x |
teal.widgets::resolve_basic_table_args( |
| 154 | 3x |
user_table = basic_table_args, |
| 155 | 3x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE) |
| 156 |
) |
|
| 157 |
) |
|
| 158 | ||
| 159 |
# layout start |
|
| 160 | 3x |
layout_list <- list() |
| 161 | 3x |
layout_list <- add_expr( |
| 162 | 3x |
layout_list, |
| 163 | 3x |
if (add_total) {
|
| 164 | ! |
substitute( |
| 165 | ! |
expr = expr_basic_table_args %>% |
| 166 | ! |
rtables::split_cols_by( |
| 167 | ! |
var = arm_var, |
| 168 | ! |
split_fun = add_overall_level(label = total_label, first = FALSE) |
| 169 |
), |
|
| 170 | ! |
env = list( |
| 171 | ! |
arm_var = arm_var, |
| 172 | ! |
total_label = total_label, |
| 173 | ! |
expr_basic_table_args = parsed_basic_table_args |
| 174 |
) |
|
| 175 |
) |
|
| 176 |
} else {
|
|
| 177 | 3x |
substitute( |
| 178 | 3x |
expr = expr_basic_table_args %>% |
| 179 | 3x |
rtables::split_cols_by(var = arm_var), |
| 180 | 3x |
env = list(arm_var = arm_var, expr_basic_table_args = parsed_basic_table_args) |
| 181 |
) |
|
| 182 |
} |
|
| 183 |
) |
|
| 184 | ||
| 185 | 3x |
layout_list <- add_expr( |
| 186 | 3x |
layout_list, |
| 187 | 3x |
substitute( |
| 188 | 3x |
expr = rtables::split_rows_by( |
| 189 | 3x |
paramcd, |
| 190 | 3x |
label_pos = "topleft", |
| 191 | 3x |
split_label = obj_label(anl[[paramcd]]) |
| 192 |
) %>% |
|
| 193 | 3x |
summarize_num_patients( |
| 194 | 3x |
var = id_var, |
| 195 | 3x |
required = "GRADE_ANL", |
| 196 | 3x |
.stats = "unique_count" |
| 197 |
) %>% |
|
| 198 | 3x |
rtables::split_rows_by( |
| 199 | 3x |
"GRADE_DIR", |
| 200 | 3x |
label_pos = "topleft", |
| 201 | 3x |
split_fun = trim_levels_to_map(map = map), |
| 202 | 3x |
split_label = obj_label(anl$GRADE_DIR) |
| 203 |
) %>% |
|
| 204 | 3x |
count_abnormal_by_worst_grade( |
| 205 | 3x |
var = "GRADE_ANL", |
| 206 | 3x |
variables = list(id = id_var, param = paramcd, grade_dir = "GRADE_DIR"), |
| 207 | 3x |
.indent_mods = 4L |
| 208 |
) %>% |
|
| 209 | 3x |
rtables::append_topleft(" Highest Grade"),
|
| 210 | 3x |
env = list( |
| 211 | 3x |
paramcd = paramcd, |
| 212 | 3x |
id_var = id_var |
| 213 |
) |
|
| 214 |
) |
|
| 215 |
) |
|
| 216 | ||
| 217 | 3x |
y$layout <- substitute( |
| 218 | 3x |
expr = lyt <- layout_pipe, |
| 219 | 3x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 220 |
) |
|
| 221 | ||
| 222 | 3x |
y$table <- substitute( |
| 223 | 3x |
expr = {
|
| 224 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 225 | ! |
result |
| 226 |
}, |
|
| 227 | 3x |
env = list(parent = as.name(parentname)) |
| 228 |
) |
|
| 229 | ||
| 230 | 3x |
y |
| 231 |
} |
|
| 232 | ||
| 233 |
#' teal Module: Laboratory test results with highest grade post-baseline |
|
| 234 |
#' |
|
| 235 |
#' This module produces a table to summarize laboratory test results with highest grade post-baseline |
|
| 236 | ||
| 237 |
#' @inheritParams module_arguments |
|
| 238 |
#' @inheritParams template_abnormality_by_worst_grade |
|
| 239 |
#' @param atoxgr_var ([teal.transform::choices_selected()])\cr |
|
| 240 |
#' object with all available choices and preselected option |
|
| 241 |
#' for variable names that can be used as Analysis Toxicity Grade. |
|
| 242 |
#' @param worst_high_flag_var ([teal.transform::choices_selected()])\cr |
|
| 243 |
#' object with all available choices and preselected option for variable names that can be used as Worst High |
|
| 244 |
#' Grade flag. |
|
| 245 |
#' @param worst_low_flag_var ([teal.transform::choices_selected()])\cr |
|
| 246 |
#' object with all available choices and preselected option for variable names that can be used as Worst Low Grade flag. |
|
| 247 |
#' @param worst_flag_indicator ([teal.transform::choices_selected()])\cr |
|
| 248 |
#' value indicating worst grade. |
|
| 249 |
#' |
|
| 250 |
#' @inherit module_arguments return seealso |
|
| 251 |
#' |
|
| 252 |
#' @export |
|
| 253 |
#' |
|
| 254 |
#' @examples |
|
| 255 |
#' library(dplyr) |
|
| 256 |
#' |
|
| 257 |
#' ADSL <- tmc_ex_adsl |
|
| 258 |
#' ADLB <- tmc_ex_adlb %>% |
|
| 259 |
#' filter(!AVISIT %in% c("SCREENING", "BASELINE"))
|
|
| 260 |
#' |
|
| 261 |
#' app <- init( |
|
| 262 |
#' data = cdisc_data( |
|
| 263 |
#' ADSL = ADSL, |
|
| 264 |
#' ADLB = ADLB, |
|
| 265 |
#' code = " |
|
| 266 |
#' ADSL <- tmc_ex_adsl |
|
| 267 |
#' ADLB <- tmc_ex_adlb %>% |
|
| 268 |
#' filter(!AVISIT %in% c(\"SCREENING\", \"BASELINE\")) |
|
| 269 |
#' " |
|
| 270 |
#' ), |
|
| 271 |
#' modules = modules( |
|
| 272 |
#' tm_t_abnormality_by_worst_grade( |
|
| 273 |
#' label = "Laboratory Test Results with Highest Grade Post-Baseline", |
|
| 274 |
#' dataname = "ADLB", |
|
| 275 |
#' arm_var = choices_selected( |
|
| 276 |
#' choices = variable_choices(ADSL, subset = c("ARM", "ARMCD")),
|
|
| 277 |
#' selected = "ARM" |
|
| 278 |
#' ), |
|
| 279 |
#' paramcd = choices_selected( |
|
| 280 |
#' choices = value_choices(ADLB, "PARAMCD", "PARAM"), |
|
| 281 |
#' selected = c("ALT", "CRP", "IGA")
|
|
| 282 |
#' ), |
|
| 283 |
#' add_total = FALSE |
|
| 284 |
#' ) |
|
| 285 |
#' ), |
|
| 286 |
#' filter = teal_slices( |
|
| 287 |
#' teal_slice("ADSL", "SAFFL", selected = "Y"),
|
|
| 288 |
#' teal_slice("ADLB", "ONTRTFL", selected = "Y")
|
|
| 289 |
#' ) |
|
| 290 |
#' ) |
|
| 291 |
#' if (interactive()) {
|
|
| 292 |
#' shinyApp(app$ui, app$server) |
|
| 293 |
#' } |
|
| 294 |
#' |
|
| 295 |
tm_t_abnormality_by_worst_grade <- function(label, # nolint: object_length. |
|
| 296 |
dataname, |
|
| 297 |
parentname = ifelse( |
|
| 298 |
inherits(arm_var, "data_extract_spec"), |
|
| 299 |
teal.transform::datanames_input(arm_var), |
|
| 300 |
"ADSL" |
|
| 301 |
), |
|
| 302 |
arm_var, |
|
| 303 |
id_var = teal.transform::choices_selected( |
|
| 304 |
teal.transform::variable_choices( |
|
| 305 |
dataname, |
|
| 306 |
subset = "USUBJID" |
|
| 307 |
), |
|
| 308 |
selected = "USUBJID", fixed = TRUE |
|
| 309 |
), |
|
| 310 |
paramcd, |
|
| 311 |
atoxgr_var = teal.transform::choices_selected( |
|
| 312 |
teal.transform::variable_choices( |
|
| 313 |
dataname, |
|
| 314 |
subset = "ATOXGR" |
|
| 315 |
), |
|
| 316 |
selected = "ATOXGR", fixed = TRUE |
|
| 317 |
), |
|
| 318 |
worst_high_flag_var = teal.transform::choices_selected( |
|
| 319 |
teal.transform::variable_choices( |
|
| 320 |
dataname, |
|
| 321 |
subset = "WGRHIFL" |
|
| 322 |
), |
|
| 323 |
selected = "WGRHIFL", fixed = TRUE |
|
| 324 |
), |
|
| 325 |
worst_low_flag_var = teal.transform::choices_selected( |
|
| 326 |
teal.transform::variable_choices( |
|
| 327 |
dataname, |
|
| 328 |
subset = "WGRLOFL" |
|
| 329 |
), |
|
| 330 |
selected = "WGRLOFL", fixed = TRUE |
|
| 331 |
), |
|
| 332 |
worst_flag_indicator = teal.transform::choices_selected("Y"),
|
|
| 333 |
add_total = TRUE, |
|
| 334 |
total_label = default_total_label(), |
|
| 335 |
drop_arm_levels = TRUE, |
|
| 336 |
pre_output = NULL, |
|
| 337 |
post_output = NULL, |
|
| 338 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 339 | ! |
message("Initializing tm_t_abnormality_by_worst_grade")
|
| 340 | ! |
checkmate::assert_string(label) |
| 341 | ! |
checkmate::assert_string(dataname) |
| 342 | ! |
checkmate::assert_string(parentname) |
| 343 | ! |
checkmate::assert_string(total_label) |
| 344 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 345 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 346 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 347 | ! |
checkmate::assert_class(atoxgr_var, "choices_selected") |
| 348 | ! |
checkmate::assert_class(worst_high_flag_var, "choices_selected") |
| 349 | ! |
checkmate::assert_class(worst_low_flag_var, "choices_selected") |
| 350 | ! |
checkmate::assert_class(worst_flag_indicator, "choices_selected") |
| 351 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 352 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 353 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 354 | ||
| 355 | ! |
data_extract_list <- list( |
| 356 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 357 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 358 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname, multiple = TRUE), |
| 359 | ! |
atoxgr_var = cs_to_des_select(atoxgr_var, dataname = dataname), |
| 360 | ! |
worst_high_flag_var = cs_to_des_select(worst_high_flag_var, dataname = dataname), |
| 361 | ! |
worst_low_flag_var = cs_to_des_select(worst_low_flag_var, dataname = dataname) |
| 362 |
) |
|
| 363 | ||
| 364 | ! |
args <- as.list(environment()) |
| 365 | ||
| 366 | ! |
module( |
| 367 | ! |
label = label, |
| 368 | ! |
ui = ui_t_abnormality_by_worst_grade, |
| 369 | ! |
server = srv_t_abnormality_by_worst_grade, |
| 370 | ! |
ui_args = c(data_extract_list, args), |
| 371 | ! |
server_args = c( |
| 372 | ! |
data_extract_list, |
| 373 | ! |
list( |
| 374 | ! |
dataname = dataname, |
| 375 | ! |
parentname = parentname, |
| 376 | ! |
label = label, |
| 377 | ! |
worst_flag_indicator = worst_flag_indicator, |
| 378 | ! |
total_label = total_label, |
| 379 | ! |
basic_table_args = basic_table_args |
| 380 |
) |
|
| 381 |
), |
|
| 382 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 383 |
) |
|
| 384 |
} |
|
| 385 | ||
| 386 |
#' @keywords internal |
|
| 387 |
ui_t_abnormality_by_worst_grade <- function(id, ...) { # nolint: object_length.
|
|
| 388 | ||
| 389 | ! |
ns <- NS(id) |
| 390 | ! |
a <- list(...) # module args |
| 391 | ||
| 392 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 393 | ! |
a$arm_var, |
| 394 | ! |
a$id_var, |
| 395 | ! |
a$paramcd, |
| 396 | ! |
a$atoxgr_var, |
| 397 | ! |
a$worst_high_flag_var, |
| 398 | ! |
a$worst_low_flag_var, |
| 399 | ! |
a$worst_flag_indicator |
| 400 |
) |
|
| 401 | ||
| 402 | ! |
teal.widgets::standard_layout( |
| 403 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 404 | ! |
encoding = tags$div( |
| 405 |
### Reporter |
|
| 406 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 407 |
### |
|
| 408 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 409 | ! |
teal.transform::datanames_input( |
| 410 | ! |
a[c( |
| 411 | ! |
"arm_var", |
| 412 | ! |
"id_var", |
| 413 | ! |
"paramcd", |
| 414 | ! |
"atoxgr_var", |
| 415 | ! |
"worst_high_flag_var", |
| 416 | ! |
"worst_low_flag_var", |
| 417 | ! |
"worst_flag_indicator" |
| 418 |
)] |
|
| 419 |
), |
|
| 420 | ! |
teal.transform::data_extract_ui( |
| 421 | ! |
id = ns("arm_var"),
|
| 422 | ! |
label = "Select Treatment Variable", |
| 423 | ! |
data_extract_spec = a$arm_var, |
| 424 | ! |
is_single_dataset = is_single_dataset_value |
| 425 |
), |
|
| 426 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = FALSE),
|
| 427 | ! |
teal.transform::data_extract_ui( |
| 428 | ! |
id = ns("paramcd"),
|
| 429 | ! |
label = "Select Lab Parameter", |
| 430 | ! |
data_extract_spec = a$paramcd, |
| 431 | ! |
is_single_dataset = is_single_dataset_value |
| 432 |
), |
|
| 433 | ! |
teal.transform::data_extract_ui( |
| 434 | ! |
id = ns("atoxgr_var"),
|
| 435 | ! |
label = "Analysis toxicity grade", |
| 436 | ! |
data_extract_spec = a$atoxgr_var, |
| 437 | ! |
is_single_dataset = is_single_dataset_value |
| 438 |
), |
|
| 439 | ! |
teal.transform::data_extract_ui( |
| 440 | ! |
id = ns("worst_low_flag_var"),
|
| 441 | ! |
label = "Worst low flag variable", |
| 442 | ! |
data_extract_spec = a$worst_low_flag_var, |
| 443 | ! |
is_single_dataset = is_single_dataset_value |
| 444 |
), |
|
| 445 | ! |
teal.transform::data_extract_ui( |
| 446 | ! |
id = ns("worst_high_flag_var"),
|
| 447 | ! |
label = "Worst high flag variable", |
| 448 | ! |
data_extract_spec = a$worst_high_flag_var, |
| 449 | ! |
is_single_dataset = is_single_dataset_value |
| 450 |
), |
|
| 451 | ! |
teal.widgets::panel_group( |
| 452 | ! |
teal.widgets::panel_item( |
| 453 | ! |
"Additional table settings", |
| 454 | ! |
teal.transform::data_extract_ui( |
| 455 | ! |
id = ns("id_var"),
|
| 456 | ! |
label = "Subject Identifier", |
| 457 | ! |
data_extract_spec = a$id_var, |
| 458 | ! |
is_single_dataset = is_single_dataset_value |
| 459 |
), |
|
| 460 | ! |
teal.widgets::optionalSelectInput( |
| 461 | ! |
ns("worst_flag_indicator"),
|
| 462 | ! |
label = "Value Indicating Worst Grade", |
| 463 | ! |
multiple = FALSE, |
| 464 | ! |
fixed_on_single = TRUE |
| 465 |
), |
|
| 466 | ! |
checkboxInput( |
| 467 | ! |
ns("drop_arm_levels"),
|
| 468 | ! |
label = "Drop columns not in filtered analysis dataset", |
| 469 | ! |
value = a$drop_arm_levels |
| 470 |
) |
|
| 471 |
) |
|
| 472 |
) |
|
| 473 |
), |
|
| 474 | ! |
forms = tagList( |
| 475 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 476 |
), |
|
| 477 | ! |
pre_output = a$pre_output, |
| 478 | ! |
post_output = a$post_output |
| 479 |
) |
|
| 480 |
} |
|
| 481 | ||
| 482 |
#' @keywords internal |
|
| 483 |
srv_t_abnormality_by_worst_grade <- function(id, # nolint: object_length. |
|
| 484 |
data, |
|
| 485 |
reporter, |
|
| 486 |
filter_panel_api, |
|
| 487 |
dataname, |
|
| 488 |
parentname, |
|
| 489 |
id_var, |
|
| 490 |
arm_var, |
|
| 491 |
paramcd, |
|
| 492 |
atoxgr_var, |
|
| 493 |
worst_flag_indicator, |
|
| 494 |
worst_low_flag_var, |
|
| 495 |
worst_high_flag_var, |
|
| 496 |
add_total, |
|
| 497 |
total_label, |
|
| 498 |
drop_arm_levels, |
|
| 499 |
label, |
|
| 500 |
basic_table_args) {
|
|
| 501 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 502 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 503 | ! |
checkmate::assert_class(data, "reactive") |
| 504 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 505 | ||
| 506 | ! |
moduleServer(id, function(input, output, session) {
|
| 507 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 508 | ! |
isolate({
|
| 509 | ! |
resolved <- teal.transform::resolve_delayed(worst_flag_indicator, as.list(data()@env)) |
| 510 | ! |
teal.widgets::updateOptionalSelectInput( |
| 511 | ! |
session = session, |
| 512 | ! |
inputId = "worst_flag_indicator", |
| 513 | ! |
choices = resolved$choices, |
| 514 | ! |
selected = resolved$selected |
| 515 |
) |
|
| 516 |
}) |
|
| 517 | ||
| 518 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 519 | ! |
data_extract = list( |
| 520 | ! |
arm_var = arm_var, |
| 521 | ! |
id_var = id_var, |
| 522 | ! |
paramcd = paramcd, |
| 523 | ! |
atoxgr_var = atoxgr_var, |
| 524 | ! |
worst_high_flag_var = worst_high_flag_var, |
| 525 | ! |
worst_low_flag_var = worst_low_flag_var |
| 526 |
), |
|
| 527 | ! |
datasets = data, |
| 528 | ! |
select_validation_rule = list( |
| 529 | ! |
arm_var = shinyvalidate::sv_required("Please select a treatment variable."),
|
| 530 | ! |
id_var = shinyvalidate::sv_required("Please select a Subject Identifier."),
|
| 531 | ! |
atoxgr_var = shinyvalidate::sv_required("Please select Analysis Toxicity Grade variable."),
|
| 532 | ! |
worst_low_flag_var = shinyvalidate::sv_required("Please select the Worst Low Grade flag variable."),
|
| 533 | ! |
worst_high_flag_var = shinyvalidate::sv_required("Please select the Worst High Grade flag variable.")
|
| 534 |
), |
|
| 535 | ! |
filter_validation_rule = list( |
| 536 | ! |
paramcd = shinyvalidate::sv_required("Please select at least one Laboratory parameter.")
|
| 537 |
) |
|
| 538 |
) |
|
| 539 | ||
| 540 | ! |
iv_r <- reactive({
|
| 541 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 542 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 543 | ! |
iv$add_rule( |
| 544 | ! |
"worst_flag_indicator", |
| 545 | ! |
~ if (length(.) == 0) {
|
| 546 | ! |
"Please select the value indicating worst grade." |
| 547 |
} |
|
| 548 |
) |
|
| 549 |
}) |
|
| 550 | ||
| 551 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 552 | ! |
selector_list = selector_list, |
| 553 | ! |
datasets = data, |
| 554 | ! |
merge_function = "dplyr::inner_join" |
| 555 |
) |
|
| 556 | ||
| 557 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 558 | ! |
datasets = data, |
| 559 | ! |
data_extract = list(arm_var = arm_var), |
| 560 | ! |
anl_name = "ANL_ADSL" |
| 561 |
) |
|
| 562 | ||
| 563 | ! |
anl_q <- reactive({
|
| 564 | ! |
data() %>% |
| 565 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 566 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 567 |
}) |
|
| 568 | ||
| 569 | ! |
merged <- list( |
| 570 | ! |
anl_input_r = anl_inputs, |
| 571 | ! |
adsl_input_r = adsl_inputs, |
| 572 | ! |
anl_q = anl_q |
| 573 |
) |
|
| 574 | ||
| 575 | ! |
validate_checks <- reactive({
|
| 576 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 577 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 578 | ! |
anl <- merged$anl_q()[["ANL"]] |
| 579 | ||
| 580 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 581 | ! |
input_paramcd_var <- names(merged$anl_input_r()$columns_source$paramcd) |
| 582 | ! |
input_atoxgr <- names(merged$anl_input_r()$columns_source$atoxgr_var) |
| 583 | ! |
input_worst_high_flag_var <- names(merged$anl_input_r()$columns_source$worst_high_flag_var) |
| 584 | ! |
input_worst_low_flag_var <- names(merged$anl_input_r()$columns_source$worst_low_flag_var) |
| 585 | ||
| 586 | ! |
teal::validate_inputs(iv_r()) |
| 587 | ||
| 588 | ! |
if (length(input_paramcd_var) > 0) {
|
| 589 | ! |
validate( |
| 590 | ! |
need( |
| 591 | ! |
is.factor(anl[[input_paramcd_var]]), |
| 592 | ! |
"Parameter variable should be a factor." |
| 593 |
) |
|
| 594 |
) |
|
| 595 |
} |
|
| 596 | ||
| 597 | ! |
if (length(input_atoxgr) > 0) {
|
| 598 | ! |
validate( |
| 599 | ! |
need( |
| 600 | ! |
all(as.character(unique(anl[[input_atoxgr]])) %in% as.character(c(-4:4))), |
| 601 | ! |
"All grade values should be within -4:4 range." |
| 602 |
), |
|
| 603 | ! |
need( |
| 604 | ! |
is.factor(anl[[input_atoxgr]]), |
| 605 | ! |
"Grade variable should be a factor." |
| 606 |
), |
|
| 607 | ! |
need( |
| 608 | ! |
all(sapply(1:4, function(y) any(abs(as.numeric(as.character(anl[[input_atoxgr]]))) == y))), |
| 609 | ! |
paste( |
| 610 | ! |
"To display the table there must be at least one record for", |
| 611 | ! |
"each highest grade (in either direction).\n\n", |
| 612 | ! |
"Please remove filter(s) or select a different lab parameter." |
| 613 |
) |
|
| 614 |
) |
|
| 615 |
) |
|
| 616 |
} |
|
| 617 | ||
| 618 | ! |
if (length(input_atoxgr) > 0) {
|
| 619 | ! |
validate( |
| 620 | ! |
need( |
| 621 | ! |
is.factor(anl[[input_atoxgr]]), |
| 622 | ! |
"Treatment variable should be a factor." |
| 623 |
), |
|
| 624 |
) |
|
| 625 |
} |
|
| 626 | ||
| 627 |
# validate inputs |
|
| 628 | ! |
validate_standard_inputs( |
| 629 | ! |
adsl = adsl_filtered, |
| 630 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 631 | ! |
anl = anl_filtered, |
| 632 | ! |
anlvars = c( |
| 633 | ! |
"USUBJID", "STUDYID", input_paramcd_var, |
| 634 | ! |
input_atoxgr, input_worst_high_flag_var, |
| 635 | ! |
input_worst_low_flag_var |
| 636 |
), |
|
| 637 | ! |
arm_var = input_arm_var |
| 638 |
) |
|
| 639 |
}) |
|
| 640 | ||
| 641 | ! |
all_q <- reactive({
|
| 642 | ! |
validate_checks() |
| 643 | ||
| 644 | ! |
my_calls <- template_abnormality_by_worst_grade( |
| 645 | ! |
parentname = "ANL_ADSL", |
| 646 | ! |
dataname = "ANL", |
| 647 | ! |
arm_var = names(merged$anl_input_r()$columns_source$arm_var), |
| 648 | ! |
id_var = names(merged$anl_input_r()$columns_source$id_var), |
| 649 | ! |
paramcd = names(merged$anl_input_r()$columns_source$paramcd), |
| 650 | ! |
atoxgr_var = names(merged$anl_input_r()$columns_source$atoxgr_var), |
| 651 | ! |
worst_high_flag_var = names(merged$anl_input_r()$columns_source$worst_high_flag_var), |
| 652 | ! |
worst_low_flag_var = names(merged$anl_input_r()$columns_source$worst_low_flag_var), |
| 653 | ! |
worst_flag_indicator = input$worst_flag_indicator, |
| 654 | ! |
add_total = input$add_total, |
| 655 | ! |
total_label = total_label, |
| 656 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 657 | ! |
basic_table_args = basic_table_args |
| 658 |
) |
|
| 659 | ||
| 660 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 661 |
}) |
|
| 662 | ||
| 663 |
# Outputs to render. |
|
| 664 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 665 | ||
| 666 | ! |
teal.widgets::table_with_settings_srv( |
| 667 | ! |
id = "table", |
| 668 | ! |
table_r = table_r |
| 669 |
) |
|
| 670 | ||
| 671 |
# Render R code. |
|
| 672 | ! |
teal.widgets::verbatim_popup_srv( |
| 673 | ! |
id = "rcode", |
| 674 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 675 | ! |
title = label |
| 676 |
) |
|
| 677 | ||
| 678 |
### REPORTER |
|
| 679 | ! |
if (with_reporter) {
|
| 680 | ! |
card_fun <- function(comment, label) {
|
| 681 | ! |
card <- teal::report_card_template( |
| 682 | ! |
title = "Laboratory Test Results Table", |
| 683 | ! |
label = label, |
| 684 | ! |
description = "Laboratory test results with highest grade post-baseline Table", |
| 685 | ! |
with_filter = with_filter, |
| 686 | ! |
filter_panel_api = filter_panel_api |
| 687 |
) |
|
| 688 | ! |
card$append_text("Table", "header3")
|
| 689 | ! |
card$append_table(table_r()) |
| 690 | ! |
if (!comment == "") {
|
| 691 | ! |
card$append_text("Comment", "header3")
|
| 692 | ! |
card$append_text(comment) |
| 693 |
} |
|
| 694 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 695 | ! |
card |
| 696 |
} |
|
| 697 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 698 |
} |
|
| 699 |
### |
|
| 700 |
}) |
|
| 701 |
} |
| 1 |
#' Template: ANCOVA Summary |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate an analysis of variance summary table. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param paramcd_levels (`character`)\cr |
|
| 7 |
#' variable levels for the studied parameter. |
|
| 8 |
#' @param paramcd_var (`character`)\cr |
|
| 9 |
#' variable name for the studied parameter. |
|
| 10 |
#' @param visit_levels (`character`)\cr |
|
| 11 |
#' variable levels for studied visits. |
|
| 12 |
#' @param label_aval (`character`)\cr |
|
| 13 |
#' label of value variable used for title rendering. |
|
| 14 |
#' @param label_paramcd (`character`)\cr |
|
| 15 |
#' variable label used for title rendering. |
|
| 16 |
#' @param interact_var (`character`)\cr name of the variable that should have interactions with arm. If the |
|
| 17 |
#' interaction is not needed, the default option is `NULL`. |
|
| 18 |
#' @param interact_y (`character`)\cr a selected item from the `interact_var` column which will be used to select the |
|
| 19 |
#' specific ANCOVA results. If the interaction is not needed, the default option is `FALSE`. |
|
| 20 |
#' |
|
| 21 |
#' @inherit template_arguments return |
|
| 22 |
#' |
|
| 23 |
#' @seealso [tm_t_ancova()] |
|
| 24 |
#' |
|
| 25 |
#' @keywords internal |
|
| 26 |
template_ancova <- function(dataname = "ANL", |
|
| 27 |
parentname = "ADSL", |
|
| 28 |
arm_var, |
|
| 29 |
ref_arm = NULL, |
|
| 30 |
comp_arm = NULL, |
|
| 31 |
combine_comp_arms = FALSE, |
|
| 32 |
aval_var, |
|
| 33 |
label_aval = NULL, |
|
| 34 |
cov_var, |
|
| 35 |
include_interact = FALSE, |
|
| 36 |
interact_var = NULL, |
|
| 37 |
interact_y = FALSE, |
|
| 38 |
paramcd_levels = "", |
|
| 39 |
paramcd_var = "PARAMCD", |
|
| 40 |
label_paramcd = NULL, |
|
| 41 |
visit_levels = "", |
|
| 42 |
visit_var = "AVISIT", |
|
| 43 |
conf_level = 0.95, |
|
| 44 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 45 | 7x |
checkmate::assert_string(dataname) |
| 46 | 7x |
checkmate::assert_string(parentname) |
| 47 | 7x |
checkmate::assert_string(arm_var) |
| 48 | 7x |
checkmate::assert_string(label_aval, null.ok = TRUE) |
| 49 | 7x |
checkmate::assert_flag(combine_comp_arms) |
| 50 | 7x |
checkmate::assert_string(aval_var) |
| 51 | 7x |
checkmate::assert_character(cov_var) |
| 52 | 7x |
checkmate::assert_flag(include_interact) |
| 53 | 2x |
if (!isFALSE(interact_y)) checkmate::assert_character(interact_y) |
| 54 | 7x |
checkmate::assert_string(interact_var, null.ok = TRUE) |
| 55 | ||
| 56 | 7x |
y <- list() |
| 57 | ||
| 58 | 7x |
if (include_interact && !any(interact_y == "") && !is.null(interact_var)) {
|
| 59 | 3x |
cov_var <- c(cov_var, paste0(arm_var, "*", interact_var)) |
| 60 |
} |
|
| 61 | ||
| 62 | 7x |
if (length(cov_var) == 0) {
|
| 63 | ! |
cov_var <- NULL |
| 64 |
} |
|
| 65 | ||
| 66 |
# Data processing. |
|
| 67 | 7x |
data_list <- list() |
| 68 | 7x |
anl_list <- list() |
| 69 | 7x |
parent_list <- list() |
| 70 | 7x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 71 | ||
| 72 | 7x |
anl_list <- add_expr( |
| 73 | 7x |
anl_list, |
| 74 | 7x |
prepare_arm( |
| 75 | 7x |
dataname = dataname, |
| 76 | 7x |
arm_var = arm_var, |
| 77 | 7x |
ref_arm = ref_arm, |
| 78 | 7x |
comp_arm = comp_arm, |
| 79 | 7x |
ref_arm_val = ref_arm_val, |
| 80 | 7x |
drop = FALSE |
| 81 |
) |
|
| 82 |
) |
|
| 83 | 7x |
anl_list <- add_expr(anl_list, quote(droplevels())) |
| 84 | ||
| 85 | 7x |
parent_list <- add_expr( |
| 86 | 7x |
parent_list, |
| 87 | 7x |
prepare_arm( |
| 88 | 7x |
dataname = parentname, |
| 89 | 7x |
arm_var = arm_var, |
| 90 | 7x |
ref_arm = ref_arm, |
| 91 | 7x |
comp_arm = comp_arm, |
| 92 | 7x |
ref_arm_val = ref_arm_val, |
| 93 | 7x |
drop = FALSE |
| 94 |
) |
|
| 95 |
) |
|
| 96 | 7x |
parent_list <- add_expr(parent_list, quote(droplevels())) |
| 97 | ||
| 98 | 7x |
if (combine_comp_arms) {
|
| 99 | 1x |
anl_list <- add_expr( |
| 100 | 1x |
anl_list, |
| 101 | 1x |
substitute_names( |
| 102 | 1x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = comp_arm)), |
| 103 | 1x |
names = list(arm_var = as.name(arm_var)), |
| 104 | 1x |
others = list(comp_arm = comp_arm) |
| 105 |
) |
|
| 106 |
) |
|
| 107 | 1x |
parent_list <- add_expr( |
| 108 | 1x |
parent_list, |
| 109 | 1x |
substitute_names( |
| 110 | 1x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = comp_arm)), |
| 111 | 1x |
names = list(arm_var = as.name(arm_var)), |
| 112 | 1x |
others = list(comp_arm = comp_arm) |
| 113 |
) |
|
| 114 |
) |
|
| 115 |
} |
|
| 116 | ||
| 117 | 7x |
anl_list <- add_expr(anl_list, quote(df_explicit_na(na_level = default_na_str()))) |
| 118 | 7x |
parent_list <- add_expr(parent_list, quote(df_explicit_na(na_level = default_na_str()))) |
| 119 | ||
| 120 | 7x |
data_list <- add_expr( |
| 121 | 7x |
data_list, |
| 122 | 7x |
substitute( |
| 123 | 7x |
anl <- anl_list, |
| 124 | 7x |
env = list( |
| 125 | 7x |
anl = as.name(dataname), |
| 126 | 7x |
anl_list = pipe_expr(anl_list) |
| 127 |
) |
|
| 128 |
) |
|
| 129 |
) |
|
| 130 | ||
| 131 | 7x |
data_list <- add_expr( |
| 132 | 7x |
data_list, |
| 133 | 7x |
substitute( |
| 134 | 7x |
parent <- parent_list, |
| 135 | 7x |
env = list( |
| 136 | 7x |
parent = as.name(parentname), |
| 137 | 7x |
parent_list = pipe_expr(parent_list) |
| 138 |
) |
|
| 139 |
) |
|
| 140 |
) |
|
| 141 | ||
| 142 | 7x |
y$data <- bracket_expr(data_list) |
| 143 | ||
| 144 |
# Build layout. |
|
| 145 | 7x |
visits_title <- if (length(visit_levels) > 1) {
|
| 146 | ! |
paste( |
| 147 | ! |
paste(utils::head(visit_levels, -1), collapse = ", "), |
| 148 | ! |
"and", utils::tail(visit_levels, 1) |
| 149 |
) |
|
| 150 | 7x |
} else if (length(visit_levels) == 1) {
|
| 151 | 7x |
visit_levels |
| 152 |
} else {
|
|
| 153 |
"" |
|
| 154 |
} |
|
| 155 | ||
| 156 | 7x |
table_title <- if (length(label_paramcd) > 1) {
|
| 157 | 6x |
paste( |
| 158 | 6x |
"Summary of Analysis of Variance for", paste(label_paramcd, collapse = " and "), |
| 159 | 6x |
"at", visits_title, "for", label_aval |
| 160 |
) |
|
| 161 | 7x |
} else if (length(label_paramcd == 1)) {
|
| 162 | 1x |
paste("Summary of Analysis of Variance for", label_paramcd, "at", visits_title, "for", label_aval)
|
| 163 |
} else {
|
|
| 164 |
"" |
|
| 165 |
} |
|
| 166 | ||
| 167 | 7x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 168 | 7x |
teal.widgets::resolve_basic_table_args( |
| 169 | 7x |
user_table = basic_table_args, |
| 170 | 7x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE, title = table_title) |
| 171 |
) |
|
| 172 |
) |
|
| 173 | ||
| 174 | 7x |
y$layout_prep <- quote(split_fun <- drop_split_levels) |
| 175 | 7x |
layout_list <- list() |
| 176 | 7x |
layout_list <- add_expr( |
| 177 | 7x |
layout_list, |
| 178 | 7x |
parsed_basic_table_args |
| 179 |
) |
|
| 180 | ||
| 181 | 7x |
layout_list <- add_expr( |
| 182 | 7x |
layout_list, |
| 183 | 7x |
substitute( |
| 184 | 7x |
expr = rtables::split_cols_by(var = arm_var, ref_group = ref_group) %>% |
| 185 | 7x |
rtables::split_rows_by( |
| 186 | 7x |
visit_var, |
| 187 | 7x |
split_fun = split_fun, |
| 188 | 7x |
label_pos = "topleft", |
| 189 | 7x |
split_label = teal.data::col_labels(dataname[visit_var], fill = TRUE) |
| 190 |
), |
|
| 191 | 7x |
env = list( |
| 192 | 7x |
arm_var = arm_var, |
| 193 | 7x |
ref_group = paste(ref_arm, collapse = "/"), |
| 194 | 7x |
visit_var = visit_var, |
| 195 | 7x |
dataname = as.name(dataname) |
| 196 |
) |
|
| 197 |
) |
|
| 198 |
) |
|
| 199 | ||
| 200 | 7x |
if (length(paramcd_levels) > 1) {
|
| 201 | 6x |
layout_list <- add_expr( |
| 202 | 6x |
layout_list, |
| 203 | 6x |
substitute( |
| 204 | 6x |
rtables::split_rows_by( |
| 205 | 6x |
paramcd_var, |
| 206 | 6x |
split_fun = split_fun, |
| 207 | 6x |
label_pos = "topleft", |
| 208 | 6x |
split_label = teal.data::col_labels(dataname[paramcd_var], fill = TRUE) |
| 209 |
), |
|
| 210 | 6x |
env = list( |
| 211 | 6x |
paramcd_var = paramcd_var, |
| 212 | 6x |
dataname = as.name(dataname) |
| 213 |
) |
|
| 214 |
) |
|
| 215 |
) |
|
| 216 |
} else {
|
|
| 217 | 1x |
layout_list <- add_expr( |
| 218 | 1x |
layout_list, |
| 219 | 1x |
substitute( |
| 220 | 1x |
rtables::append_topleft(paste0(" ", paramcd_levels)),
|
| 221 | 1x |
env = list( |
| 222 | 1x |
paramcd_levels = paramcd_levels |
| 223 |
) |
|
| 224 |
) |
|
| 225 |
) |
|
| 226 |
} |
|
| 227 | ||
| 228 | 7x |
if (!include_interact) {
|
| 229 | 4x |
if (length(paramcd_levels) > 1) {
|
| 230 | 3x |
if (length(cov_var) == 0) {
|
| 231 | ! |
ls_lbls <- c(lsmean = "Unadjusted Mean", lsmean_diff = "Difference in Unadjusted Means") |
| 232 | ! |
var_lbls <- "Unadjusted mean" |
| 233 |
} else {
|
|
| 234 | 3x |
ls_lbls <- NULL |
| 235 | 3x |
var_lbls <- "Adjusted mean" |
| 236 |
} |
|
| 237 | 3x |
layout_list <- add_expr( |
| 238 | 3x |
layout_list, |
| 239 | 3x |
substitute( |
| 240 | 3x |
summarize_ancova( |
| 241 | 3x |
vars = aval_var, |
| 242 | 3x |
variables = list(arm = arm_var, covariates = cov_var), |
| 243 | 3x |
conf_level = conf_level, |
| 244 | 3x |
var_labels = var_labels, |
| 245 | 3x |
show_labels = "hidden", |
| 246 | 3x |
.labels = ls_labels |
| 247 |
), |
|
| 248 | 3x |
env = list( |
| 249 | 3x |
aval_var = aval_var, |
| 250 | 3x |
arm_var = arm_var, |
| 251 | 3x |
cov_var = cov_var, |
| 252 | 3x |
conf_level = conf_level, |
| 253 | 3x |
var_labels = var_lbls, |
| 254 | 3x |
ls_labels = ls_lbls |
| 255 |
) |
|
| 256 |
) |
|
| 257 |
) |
|
| 258 |
} else {
|
|
| 259 |
# Only one entry in `paramcd_levels` here. |
|
| 260 | 1x |
layout_list <- add_expr( |
| 261 | 1x |
layout_list, |
| 262 | 1x |
substitute( |
| 263 | 1x |
summarize_ancova( |
| 264 | 1x |
vars = aval_var, |
| 265 | 1x |
variables = list(arm = arm_var, covariates = NULL), |
| 266 | 1x |
conf_level = conf_level, |
| 267 | 1x |
var_labels = "Unadjusted comparison", |
| 268 | 1x |
.labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means"), |
| 269 | 1x |
table_names = "unadjusted_comparison" |
| 270 |
), |
|
| 271 | 1x |
env = list( |
| 272 | 1x |
aval_var = aval_var, |
| 273 | 1x |
arm_var = arm_var, |
| 274 | 1x |
conf_level = conf_level |
| 275 |
) |
|
| 276 |
) |
|
| 277 |
) |
|
| 278 | 1x |
if (length(cov_var) > 0) {
|
| 279 | 1x |
layout_list <- add_expr( |
| 280 | 1x |
layout_list, |
| 281 | 1x |
substitute( |
| 282 | 1x |
summarize_ancova( |
| 283 | 1x |
vars = aval_var, |
| 284 | 1x |
variables = list(arm = arm_var, covariates = cov_var), |
| 285 | 1x |
conf_level = conf_level, |
| 286 | 1x |
var_labels = paste0( |
| 287 | 1x |
"Adjusted comparison (", paste(cov_var, collapse = " + "), ")"
|
| 288 |
), |
|
| 289 | 1x |
table_names = "adjusted_comparison" |
| 290 |
), |
|
| 291 | 1x |
env = list( |
| 292 | 1x |
aval_var = aval_var, |
| 293 | 1x |
arm_var = arm_var, |
| 294 | 1x |
cov_var = cov_var, |
| 295 | 1x |
conf_level = conf_level |
| 296 |
) |
|
| 297 |
) |
|
| 298 |
) |
|
| 299 |
} |
|
| 300 |
} |
|
| 301 |
} else {
|
|
| 302 | 3x |
cts_interact <- all(interact_y == FALSE) |
| 303 | 3x |
layout_list <- add_expr( |
| 304 | 3x |
layout_list, |
| 305 | 3x |
substitute( |
| 306 | 3x |
rtables::append_topleft(paste0(" Interaction Variable: ", interact_var)),
|
| 307 | 3x |
env = list( |
| 308 | 3x |
interact_var = interact_var |
| 309 |
) |
|
| 310 |
) |
|
| 311 |
) |
|
| 312 | 3x |
for (int_y in interact_y) {
|
| 313 | 3x |
if (length(paramcd_levels) > 1) {
|
| 314 | 3x |
layout_list <- add_expr( |
| 315 | 3x |
layout_list, |
| 316 | 3x |
substitute( |
| 317 | 3x |
summarize_ancova( |
| 318 | 3x |
vars = aval_var, |
| 319 | 3x |
variables = list(arm = arm_var, covariates = cov_var), |
| 320 | 3x |
conf_level = conf_level, |
| 321 | 3x |
var_labels = paste("Interaction Level:", interact_y),
|
| 322 | 3x |
show_labels = if (cts_interact) "hidden" else "visible", |
| 323 | 3x |
interaction_y = interact_y, |
| 324 | 3x |
interaction_item = interact_var |
| 325 |
), |
|
| 326 | 3x |
env = list( |
| 327 | 3x |
aval_var = aval_var, |
| 328 | 3x |
arm_var = arm_var, |
| 329 | 3x |
cov_var = cov_var, |
| 330 | 3x |
conf_level = conf_level, |
| 331 | 3x |
interact_y = int_y, |
| 332 | 3x |
interact_var = interact_var, |
| 333 | 3x |
cts_interact = cts_interact |
| 334 |
) |
|
| 335 |
) |
|
| 336 |
) |
|
| 337 |
} else {
|
|
| 338 |
# Only one entry in `paramcd_levels` here. |
|
| 339 | ! |
if (int_y == interact_y[1]) {
|
| 340 | ! |
layout_list <- add_expr( |
| 341 | ! |
layout_list, |
| 342 | ! |
substitute( |
| 343 | ! |
summarize_ancova( |
| 344 | ! |
vars = aval_var, |
| 345 | ! |
variables = list(arm = arm_var, covariates = NULL), |
| 346 | ! |
conf_level = conf_level, |
| 347 | ! |
var_labels = "Unadjusted comparison", |
| 348 | ! |
.labels = c(lsmean = "Mean", lsmean_diff = "Difference in Means"), |
| 349 | ! |
table_names = "unadjusted_comparison" |
| 350 |
), |
|
| 351 | ! |
env = list( |
| 352 | ! |
aval_var = aval_var, |
| 353 | ! |
arm_var = arm_var, |
| 354 | ! |
cov_var = cov_var, |
| 355 | ! |
conf_level = conf_level |
| 356 |
) |
|
| 357 |
) |
|
| 358 |
) |
|
| 359 |
} |
|
| 360 | ! |
if (length(cov_var) > 0) {
|
| 361 | ! |
layout_list <- add_expr( |
| 362 | ! |
layout_list, |
| 363 | ! |
substitute( |
| 364 | ! |
summarize_ancova( |
| 365 | ! |
vars = aval_var, |
| 366 | ! |
variables = list(arm = arm_var, covariates = cov_var), |
| 367 | ! |
conf_level = conf_level, |
| 368 | ! |
var_labels = if (cts_interact) {
|
| 369 | ! |
paste0("Adjusted comparison (", paste(cov_var, collapse = " + "), ")")
|
| 370 |
} else {
|
|
| 371 | ! |
paste0( |
| 372 | ! |
"Adjusted comparison (", paste(cov_var, collapse = " + "),
|
| 373 | ! |
"), Interaction Level: ", interact_y |
| 374 |
) |
|
| 375 |
}, |
|
| 376 | ! |
table_names = "adjusted_comparison", |
| 377 | ! |
interaction_y = interact_y, |
| 378 | ! |
interaction_item = interact_var |
| 379 |
), |
|
| 380 | ! |
env = list( |
| 381 | ! |
aval_var = aval_var, |
| 382 | ! |
arm_var = arm_var, |
| 383 | ! |
cov_var = cov_var, |
| 384 | ! |
conf_level = conf_level, |
| 385 | ! |
interact_y = int_y, |
| 386 | ! |
interact_var = interact_var, |
| 387 | ! |
cts_interact = cts_interact |
| 388 |
) |
|
| 389 |
) |
|
| 390 |
) |
|
| 391 |
} |
|
| 392 |
} |
|
| 393 |
} |
|
| 394 |
} |
|
| 395 | ||
| 396 | 7x |
y$layout <- substitute( |
| 397 | 7x |
expr = lyt <- layout_pipe, |
| 398 | 7x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 399 |
) |
|
| 400 | ||
| 401 |
# Build table. |
|
| 402 | 7x |
y$table <- substitute( |
| 403 | 7x |
expr = {
|
| 404 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 405 | ! |
result |
| 406 |
}, |
|
| 407 | 7x |
env = list( |
| 408 | 7x |
anl = as.name(dataname), |
| 409 | 7x |
parent = as.name(parentname) |
| 410 |
) |
|
| 411 |
) |
|
| 412 | ||
| 413 | 7x |
y |
| 414 |
} |
|
| 415 | ||
| 416 |
#' teal Module: ANCOVA Summary |
|
| 417 |
#' |
|
| 418 |
#' This module produces a table to summarize analysis of variance, consistent with the TLG Catalog |
|
| 419 |
#' template for `AOVT01` available [here]( |
|
| 420 |
#' https://insightsengineering.github.io/tlg-catalog/stable/tables/efficacy/aovt01.html) when multiple |
|
| 421 |
#' endpoints are selected. |
|
| 422 |
#' |
|
| 423 |
#' @inheritParams module_arguments |
|
| 424 |
#' @inheritParams template_ancova |
|
| 425 |
#' |
|
| 426 |
#' @inherit module_arguments return |
|
| 427 |
#' |
|
| 428 |
#' @details |
|
| 429 |
#' When a single endpoint is selected, both unadjusted and adjusted comparison are provided. This modules |
|
| 430 |
#' expects that the analysis data has the following variables: |
|
| 431 |
#' |
|
| 432 |
#' * `AVISIT`: variable used to filter for analysis visits. |
|
| 433 |
#' * `PARAMCD`: variable used to filter for endpoints, after filtering for `paramcd` and `avisit`, one |
|
| 434 |
#' observation per patient is expected for the analysis to be meaningful. |
|
| 435 |
#' |
|
| 436 |
#' @inherit module_arguments return seealso |
|
| 437 |
#' |
|
| 438 |
#' @examples |
|
| 439 |
#' ADSL <- tmc_ex_adsl |
|
| 440 |
#' ADQS <- tmc_ex_adqs |
|
| 441 |
#' |
|
| 442 |
#' arm_ref_comp <- list( |
|
| 443 |
#' ARM = list( |
|
| 444 |
#' ref = "B: Placebo", |
|
| 445 |
#' comp = c("A: Drug X", "C: Combination")
|
|
| 446 |
#' ), |
|
| 447 |
#' ACTARMCD = list( |
|
| 448 |
#' ref = "ARM B", |
|
| 449 |
#' comp = c("ARM A", "ARM C")
|
|
| 450 |
#' ) |
|
| 451 |
#' ) |
|
| 452 |
#' |
|
| 453 |
#' app <- init( |
|
| 454 |
#' data = cdisc_data( |
|
| 455 |
#' ADSL = ADSL, |
|
| 456 |
#' ADQS = ADQS, |
|
| 457 |
#' code = " |
|
| 458 |
#' ADSL <- tmc_ex_adsl |
|
| 459 |
#' ADQS <- tmc_ex_adqs |
|
| 460 |
#' " |
|
| 461 |
#' ), |
|
| 462 |
#' modules = modules( |
|
| 463 |
#' tm_t_ancova( |
|
| 464 |
#' label = "ANCOVA Table", |
|
| 465 |
#' dataname = "ADQS", |
|
| 466 |
#' avisit = choices_selected( |
|
| 467 |
#' choices = value_choices(ADQS, "AVISIT"), |
|
| 468 |
#' selected = "WEEK 1 DAY 8" |
|
| 469 |
#' ), |
|
| 470 |
#' arm_var = choices_selected( |
|
| 471 |
#' choices = variable_choices(ADSL, c("ARM", "ACTARMCD", "ARMCD")),
|
|
| 472 |
#' selected = "ARMCD" |
|
| 473 |
#' ), |
|
| 474 |
#' arm_ref_comp = arm_ref_comp, |
|
| 475 |
#' aval_var = choices_selected( |
|
| 476 |
#' choices = variable_choices(ADQS, c("CHG", "AVAL")),
|
|
| 477 |
#' selected = "CHG" |
|
| 478 |
#' ), |
|
| 479 |
#' cov_var = choices_selected( |
|
| 480 |
#' choices = variable_choices(ADQS, c("BASE", "STRATA1", "SEX")),
|
|
| 481 |
#' selected = "STRATA1" |
|
| 482 |
#' ), |
|
| 483 |
#' paramcd = choices_selected( |
|
| 484 |
#' choices = value_choices(ADQS, "PARAMCD", "PARAM"), |
|
| 485 |
#' selected = "FKSI-FWB" |
|
| 486 |
#' ), |
|
| 487 |
#' interact_var = choices_selected( |
|
| 488 |
#' choices = variable_choices(ADQS, c("BASE", "STRATA1", "SEX")),
|
|
| 489 |
#' selected = "STRATA1" |
|
| 490 |
#' ) |
|
| 491 |
#' ) |
|
| 492 |
#' ) |
|
| 493 |
#' ) |
|
| 494 |
#' if (interactive()) {
|
|
| 495 |
#' shinyApp(app$ui, app$server) |
|
| 496 |
#' } |
|
| 497 |
#' |
|
| 498 |
#' @export |
|
| 499 |
tm_t_ancova <- function(label, |
|
| 500 |
dataname, |
|
| 501 |
parentname = ifelse( |
|
| 502 |
inherits(arm_var, "data_extract_spec"), |
|
| 503 |
teal.transform::datanames_input(arm_var), |
|
| 504 |
"ADSL" |
|
| 505 |
), |
|
| 506 |
arm_var, |
|
| 507 |
arm_ref_comp = NULL, |
|
| 508 |
aval_var, |
|
| 509 |
cov_var, |
|
| 510 |
include_interact = FALSE, |
|
| 511 |
interact_var = NULL, |
|
| 512 |
interact_y = FALSE, |
|
| 513 |
avisit, |
|
| 514 |
paramcd, |
|
| 515 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 516 |
pre_output = NULL, |
|
| 517 |
post_output = NULL, |
|
| 518 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 519 | ! |
message("Initializing tm_t_ancova")
|
| 520 | ! |
checkmate::assert_string(label) |
| 521 | ! |
checkmate::assert_string(dataname) |
| 522 | ! |
checkmate::assert_string(parentname) |
| 523 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 524 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 525 | ! |
checkmate::assert_class(cov_var, "choices_selected") |
| 526 | ! |
checkmate::assert_class(avisit, "choices_selected") |
| 527 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 528 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 529 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 530 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 531 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 532 | ||
| 533 | ! |
args <- c(as.list(environment())) |
| 534 | ||
| 535 | ! |
if (is.null(interact_var)) {
|
| 536 | ! |
interact_var <- teal.transform::choices_selected( |
| 537 | ! |
choices = cov_var$choices, |
| 538 | ! |
selected = NULL |
| 539 |
) |
|
| 540 |
} |
|
| 541 | ||
| 542 | ! |
data_extract_list <- list( |
| 543 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 544 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 545 | ! |
cov_var = cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE), |
| 546 | ! |
avisit = cs_to_des_filter(avisit, dataname = dataname, multiple = TRUE, include_vars = TRUE), |
| 547 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname, multiple = TRUE), |
| 548 | ! |
interact_var = cs_to_des_select(interact_var, dataname = dataname) |
| 549 |
) |
|
| 550 | ||
| 551 | ! |
module( |
| 552 | ! |
label = label, |
| 553 | ! |
ui = ui_ancova, |
| 554 | ! |
ui_args = c(data_extract_list, args), |
| 555 | ! |
server = srv_ancova, |
| 556 | ! |
server_args = c( |
| 557 | ! |
data_extract_list, |
| 558 | ! |
list( |
| 559 | ! |
dataname = dataname, |
| 560 | ! |
parentname = parentname, |
| 561 | ! |
arm_ref_comp = arm_ref_comp, |
| 562 | ! |
include_interact = include_interact, |
| 563 | ! |
label = label, |
| 564 | ! |
basic_table_args = basic_table_args |
| 565 |
) |
|
| 566 |
), |
|
| 567 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 568 |
) |
|
| 569 |
} |
|
| 570 | ||
| 571 |
#' @keywords internal |
|
| 572 |
ui_ancova <- function(id, ...) {
|
|
| 573 | ! |
a <- list(...) |
| 574 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 575 | ! |
a$arm_var, a$aval_var, a$cov_var, a$avisit, a$paramcd, a$interact_var |
| 576 |
) |
|
| 577 | ||
| 578 | ! |
ns <- NS(id) |
| 579 | ||
| 580 | ! |
teal.widgets::standard_layout( |
| 581 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 582 | ! |
encoding = tags$div( |
| 583 |
### Reporter |
|
| 584 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 585 |
### |
|
| 586 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 587 | ! |
teal.transform::datanames_input(a[c("arm_var", "aval_var", "cov_var", "avisit", "paramcd", "interact_var")]),
|
| 588 | ! |
teal.transform::data_extract_ui( |
| 589 | ! |
id = ns("avisit"),
|
| 590 | ! |
label = "Analysis Visit", |
| 591 | ! |
data_extract_spec = a$avisit, |
| 592 | ! |
is_single_dataset = is_single_dataset_value |
| 593 |
), |
|
| 594 | ! |
teal.transform::data_extract_ui( |
| 595 | ! |
id = ns("paramcd"),
|
| 596 | ! |
label = "Select Endpoint", |
| 597 | ! |
data_extract_spec = a$paramcd, |
| 598 | ! |
is_single_dataset = is_single_dataset_value |
| 599 |
), |
|
| 600 | ! |
teal.transform::data_extract_ui( |
| 601 | ! |
id = ns("aval_var"),
|
| 602 | ! |
label = "Analysis Variable", |
| 603 | ! |
data_extract_spec = a$aval_var, |
| 604 | ! |
is_single_dataset = is_single_dataset_value |
| 605 |
), |
|
| 606 | ! |
teal.transform::data_extract_ui( |
| 607 | ! |
id = ns("arm_var"),
|
| 608 | ! |
label = "Select Treatment Variable", |
| 609 | ! |
data_extract_spec = a$arm_var, |
| 610 | ! |
is_single_dataset = is_single_dataset_value |
| 611 |
), |
|
| 612 | ! |
uiOutput( |
| 613 | ! |
ns("arms_buckets"),
|
| 614 | ! |
title = paste( |
| 615 | ! |
"Multiple reference groups are automatically combined into a single group", |
| 616 | ! |
"when more than one value is selected." |
| 617 |
) |
|
| 618 |
), |
|
| 619 | ! |
uiOutput(ns("helptext_ui")),
|
| 620 | ! |
checkboxInput( |
| 621 | ! |
ns("combine_comp_arms"),
|
| 622 | ! |
"Combine all comparison groups?", |
| 623 | ! |
value = FALSE |
| 624 |
), |
|
| 625 | ! |
teal.transform::data_extract_ui( |
| 626 | ! |
id = ns("cov_var"),
|
| 627 | ! |
label = "Covariates", |
| 628 | ! |
data_extract_spec = a$cov_var, |
| 629 | ! |
is_single_dataset = is_single_dataset_value |
| 630 |
), |
|
| 631 | ! |
teal.widgets::optionalSelectInput( |
| 632 | ! |
inputId = ns("conf_level"),
|
| 633 | ! |
label = HTML(paste("Confidence Level")),
|
| 634 | ! |
a$conf_level$choices, |
| 635 | ! |
a$conf_level$selected, |
| 636 | ! |
multiple = FALSE, |
| 637 | ! |
fixed = a$conf_level$fixed |
| 638 |
), |
|
| 639 | ! |
tags$div( |
| 640 | ! |
tags$label("Include Interaction Term"),
|
| 641 | ! |
shinyWidgets::switchInput( |
| 642 | ! |
inputId = ns("include_interact"),
|
| 643 | ! |
value = FALSE, |
| 644 | ! |
size = "mini" |
| 645 |
), |
|
| 646 | ! |
conditionalPanel( |
| 647 | ! |
condition = paste0("input['", ns("include_interact"), "']"),
|
| 648 | ! |
tags$div( |
| 649 | ! |
teal.transform::data_extract_ui( |
| 650 | ! |
id = ns("interact_var"),
|
| 651 | ! |
label = "Select Interaction Variable", |
| 652 | ! |
data_extract_spec = a$interact_var, |
| 653 | ! |
is_single_dataset = is_single_dataset_value |
| 654 |
), |
|
| 655 | ! |
teal.widgets::optionalSelectInput( |
| 656 | ! |
ns("interact_y"),
|
| 657 | ! |
label = "Select Interaction y", |
| 658 | ! |
choices = "", |
| 659 | ! |
selected = "", |
| 660 | ! |
multiple = TRUE, |
| 661 | ! |
fixed = FALSE |
| 662 |
) |
|
| 663 |
) |
|
| 664 |
) |
|
| 665 |
) |
|
| 666 |
), |
|
| 667 | ! |
forms = tagList( |
| 668 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 669 |
), |
|
| 670 | ! |
pre_output = a$pre_output, |
| 671 | ! |
post_output = a$post_output |
| 672 |
) |
|
| 673 |
} |
|
| 674 | ||
| 675 |
#' @keywords internal |
|
| 676 |
srv_ancova <- function(id, |
|
| 677 |
data, |
|
| 678 |
reporter, |
|
| 679 |
filter_panel_api, |
|
| 680 |
dataname, |
|
| 681 |
parentname, |
|
| 682 |
arm_var, |
|
| 683 |
arm_ref_comp, |
|
| 684 |
aval_var, |
|
| 685 |
cov_var, |
|
| 686 |
include_interact, |
|
| 687 |
interact_var, |
|
| 688 |
paramcd, |
|
| 689 |
avisit, |
|
| 690 |
label, |
|
| 691 |
basic_table_args) {
|
|
| 692 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 693 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 694 | ! |
checkmate::assert_class(data, "reactive") |
| 695 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 696 | ||
| 697 | ! |
moduleServer(id, function(input, output, session) {
|
| 698 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 699 |
# Setup arm variable selection, default reference arms, and default |
|
| 700 |
# comparison arms for encoding panel. |
|
| 701 | ! |
iv_arco <- arm_ref_comp_observer( |
| 702 | ! |
session, |
| 703 | ! |
input, |
| 704 | ! |
output, |
| 705 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 706 | ! |
data = data()[[parentname]], |
| 707 | ! |
arm_ref_comp = arm_ref_comp, |
| 708 | ! |
module = "tm_ancova" |
| 709 |
) |
|
| 710 | ||
| 711 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 712 | ! |
data_extract = list( |
| 713 | ! |
arm_var = arm_var, |
| 714 | ! |
aval_var = aval_var, |
| 715 | ! |
cov_var = cov_var, |
| 716 | ! |
avisit = avisit, |
| 717 | ! |
paramcd = paramcd, |
| 718 | ! |
interact_var = interact_var |
| 719 |
), |
|
| 720 | ! |
datasets = data, |
| 721 | ! |
select_validation_rule = list( |
| 722 | ! |
arm_var = shinyvalidate::sv_required("Arm variable cannot be empty."),
|
| 723 | ! |
aval_var = shinyvalidate::sv_required("Analysis variable cannot be empty."),
|
| 724 | ! |
cov_var = shinyvalidate::sv_optional(), |
| 725 | ! |
interact_var = shinyvalidate::sv_optional() |
| 726 |
), |
|
| 727 | ! |
filter_validation_rule = list( |
| 728 | ! |
avisit = shinyvalidate::sv_required("`Analysis Visit` field cannot be empty."),
|
| 729 | ! |
paramcd = shinyvalidate::sv_required("`Select Endpoint` is not selected.")
|
| 730 |
) |
|
| 731 |
) |
|
| 732 | ||
| 733 | ! |
iv_r <- reactive({
|
| 734 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 735 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level."))
|
| 736 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_between(
|
| 737 | ! |
0, 1, |
| 738 | ! |
message_fmt = "Confdence level must be between {left} and {right}."
|
| 739 |
)) |
|
| 740 | ! |
iv$add_validator(iv_arco) |
| 741 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 742 |
}) |
|
| 743 | ||
| 744 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 745 | ! |
selector_list = selector_list, |
| 746 | ! |
datasets = data, |
| 747 | ! |
merge_function = "dplyr::inner_join" |
| 748 |
) |
|
| 749 | ||
| 750 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 751 | ! |
datasets = data, |
| 752 | ! |
data_extract = list(arm_var = arm_var), |
| 753 | ! |
anl_name = "ANL_ADSL" |
| 754 |
) |
|
| 755 | ||
| 756 | ! |
anl_q <- reactive({
|
| 757 | ! |
data() %>% |
| 758 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 759 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 760 |
}) |
|
| 761 | ||
| 762 | ! |
merged <- list( |
| 763 | ! |
anl_input_r = anl_inputs, |
| 764 | ! |
adsl_input_r = adsl_inputs, |
| 765 | ! |
anl_q = anl_q |
| 766 |
) |
|
| 767 | ||
| 768 | ! |
output$helptext_ui <- renderUI({
|
| 769 | ! |
if (length(selector_list()$arm_var()$select) != 0) {
|
| 770 | ! |
helpText("Multiple reference groups are automatically combined into a single group.")
|
| 771 |
} |
|
| 772 |
}) |
|
| 773 | ||
| 774 |
# Event handler: |
|
| 775 |
# Update interact_y choices to all levels of selected interact_var |
|
| 776 | ! |
observeEvent( |
| 777 |
{
|
|
| 778 | ! |
input$include_interact |
| 779 | ! |
input$`interact_var-dataset_ADQS_singleextract-select` |
| 780 |
}, |
|
| 781 |
{
|
|
| 782 | ! |
interact_var <- input$`interact_var-dataset_ADQS_singleextract-select` |
| 783 | ! |
if (isTRUE(input$include_interact) && length(interact_var) > 0) {
|
| 784 | ! |
interact_choices <- sort(as.vector(unique(merged$anl_q()[[dataname]][[interact_var]]))) |
| 785 | ! |
if (all(is.numeric(interact_choices))) {
|
| 786 | ! |
shinyjs::hide("interact_y")
|
| 787 |
} else {
|
|
| 788 | ! |
interact_select <- if (!all(input$interact_y %in% interact_choices)) {
|
| 789 | ! |
interact_choices[1] |
| 790 |
} else {
|
|
| 791 | ! |
input$interact_y |
| 792 |
} |
|
| 793 | ! |
shinyjs::show("interact_y")
|
| 794 | ! |
teal.widgets::updateOptionalSelectInput( |
| 795 | ! |
session, |
| 796 | ! |
"interact_y", |
| 797 | ! |
selected = interact_select, |
| 798 | ! |
choices = interact_choices |
| 799 |
) |
|
| 800 |
} |
|
| 801 |
} |
|
| 802 |
} |
|
| 803 |
) |
|
| 804 | ||
| 805 |
# Prepare the analysis environment (filter data, check data, populate envir). |
|
| 806 | ! |
validate_checks <- reactive({
|
| 807 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 808 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 809 | ||
| 810 | ! |
teal::validate_inputs(iv_r()) |
| 811 | ||
| 812 | ! |
input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) |
| 813 | ! |
input_aval_var <- as.vector(merged$anl_input_r()$columns_source$aval_var) |
| 814 | ! |
input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) |
| 815 | ! |
input_interact_var <- as.vector(merged$anl_input_r()$columns_source$interact_var) |
| 816 | ! |
input_avisit <- unlist(avisit$filter)["vars_selected"] |
| 817 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 818 | ||
| 819 |
# Validate inputs. |
|
| 820 | ! |
validate_args <- list( |
| 821 | ! |
adsl = adsl_filtered, |
| 822 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 823 | ! |
anl = anl_filtered, |
| 824 | ! |
anlvars = c( |
| 825 | ! |
"USUBJID", "STUDYID", input_paramcd, input_avisit, input_aval_var, input_cov_var, input_interact_var |
| 826 |
), |
|
| 827 | ! |
arm_var = input_arm_var |
| 828 |
) |
|
| 829 | ! |
validate_args <- append( |
| 830 | ! |
validate_args, |
| 831 | ! |
list(ref_arm = unlist(input$buckets$Ref), comp_arm = unlist(input$buckets$Comp)) |
| 832 |
) |
|
| 833 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 834 | ||
| 835 |
# Other validations. |
|
| 836 | ! |
validate(shiny::need( |
| 837 | ! |
length(unique(adsl_filtered[[input_arm_var]])) > 1, |
| 838 | ! |
"ANCOVA table needs at least 2 arm groups to make comparisons." |
| 839 |
)) |
|
| 840 |
# check that there is at least one record with no missing data |
|
| 841 | ! |
validate(shiny::need( |
| 842 | ! |
!all(is.na(merged$anl_q()[["ANL"]][[input_aval_var]])), |
| 843 | ! |
"ANCOVA table cannot be calculated as all values are missing." |
| 844 |
)) |
|
| 845 |
# check that for each visit there is at least one record with no missing data |
|
| 846 | ! |
all_NA_dataset <- merged$anl_q()[["ANL"]] %>% # nolint: object_name. |
| 847 | ! |
dplyr::group_by(dplyr::across(dplyr::all_of(c(input_avisit, input_arm_var)))) %>% |
| 848 | ! |
dplyr::summarize(all_NA = all(is.na(.data[[input_aval_var]]))) |
| 849 | ! |
validate(shiny::need( |
| 850 | ! |
!any(all_NA_dataset$all_NA), |
| 851 | ! |
"ANCOVA table cannot be calculated as all values are missing for one visit for (at least) one arm." |
| 852 |
)) |
|
| 853 | ||
| 854 | ! |
if (input$include_interact) {
|
| 855 | ! |
if (!is.null(input_interact_var) && length(input_interact_var) > 0) {
|
| 856 | ! |
validate(shiny::need( |
| 857 | ! |
!input_interact_var %in% c(input_avisit, input_paramcd) && |
| 858 | ! |
length(as.vector(unique(anl_filtered[[input_interact_var]]))) > 1, |
| 859 | ! |
paste( |
| 860 | ! |
"Interaction variable cannot be a filter variable and must have more than one level.", |
| 861 | ! |
"Please select a different interaction variable." |
| 862 |
) |
|
| 863 |
)) |
|
| 864 | ! |
if (!all(is.numeric(as.vector(unique(anl_filtered[[input_interact_var]]))))) {
|
| 865 | ! |
validate(shiny::need( |
| 866 | ! |
!is.null(input$interact_y), |
| 867 | ! |
paste( |
| 868 | ! |
"Interaction y must be selected when a discrete variable is chosen for interact variable.", |
| 869 | ! |
"Please select an interaction y, change the interaction variable, or turn off interactions." |
| 870 |
) |
|
| 871 |
)) |
|
| 872 |
} |
|
| 873 |
} |
|
| 874 |
} |
|
| 875 | ||
| 876 | ! |
if (length(input_cov_var >= 1L)) {
|
| 877 | ! |
input_cov_var_dataset <- anl_filtered[input_cov_var] |
| 878 | ! |
validate( |
| 879 | ! |
need( |
| 880 | ! |
all(vapply(input_cov_var_dataset, function(col) length(unique(col)) > 1L, logical(1))), |
| 881 | ! |
"Selected covariates should have more than one level for showing the adjusted analysis." |
| 882 |
) |
|
| 883 |
) |
|
| 884 |
} |
|
| 885 |
}) |
|
| 886 | ||
| 887 |
# The R-code corresponding to the analysis. |
|
| 888 | ! |
table_q <- reactive({
|
| 889 | ! |
validate_checks() |
| 890 | ! |
ANL <- merged$anl_q()[["ANL"]] |
| 891 | ||
| 892 | ! |
label_paramcd <- get_paramcd_label(ANL, paramcd) |
| 893 | ! |
input_aval <- as.vector(merged$anl_input_r()$columns_source$aval_var) |
| 894 | ! |
label_aval <- if (length(input_aval) != 0) attributes(ANL[[input_aval]])$label else NULL |
| 895 | ! |
paramcd_levels <- unique(ANL[[unlist(paramcd$filter)["vars_selected"]]]) |
| 896 | ! |
visit_levels <- unique(ANL[[unlist(avisit$filter)["vars_selected"]]]) |
| 897 | ||
| 898 | ! |
interact_var <- as.vector(merged$anl_input_r()$columns_source$interact_var) |
| 899 | ! |
if (length(interact_var) > 0) {
|
| 900 | ! |
if (is.numeric(ANL[[interact_var]])) {
|
| 901 | ! |
interact_y <- FALSE |
| 902 | ! |
} else if (!all(input$interact_y %in% levels(ANL[[interact_var]]))) {
|
| 903 | ! |
interact_y <- levels(ANL[[interact_var]])[1] |
| 904 |
} else {
|
|
| 905 | ! |
interact_y <- input$interact_y |
| 906 |
} |
|
| 907 |
} else {
|
|
| 908 | ! |
interact_var <- NULL |
| 909 | ! |
if (length(input$interact_y) == 0 || all(input$interact_y == "")) {
|
| 910 | ! |
interact_y <- FALSE |
| 911 |
} |
|
| 912 |
} |
|
| 913 | ||
| 914 | ! |
my_calls <- template_ancova( |
| 915 | ! |
parentname = "ANL_ADSL", |
| 916 | ! |
dataname = "ANL", |
| 917 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 918 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 919 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 920 | ! |
combine_comp_arms = input$combine_comp_arms, |
| 921 | ! |
aval_var = as.vector(merged$anl_input_r()$columns_source$aval_var), |
| 922 | ! |
label_aval = label_aval, |
| 923 | ! |
cov_var = as.vector(merged$anl_input_r()$columns_source$cov_var), |
| 924 | ! |
include_interact = input$include_interact, |
| 925 | ! |
interact_var = interact_var, |
| 926 | ! |
interact_y = interact_y, |
| 927 | ! |
paramcd_levels = paramcd_levels, |
| 928 | ! |
paramcd_var = unlist(paramcd$filter)["vars_selected"], |
| 929 | ! |
label_paramcd = label_paramcd, |
| 930 | ! |
visit_levels = visit_levels, |
| 931 | ! |
visit_var = unlist(avisit$filter)["vars_selected"], |
| 932 | ! |
conf_level = as.numeric(input$conf_level), |
| 933 | ! |
basic_table_args = basic_table_args |
| 934 |
) |
|
| 935 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 936 |
}) |
|
| 937 | ||
| 938 |
# Output to render. |
|
| 939 | ! |
table_r <- reactive({
|
| 940 | ! |
table_q()[["result"]] |
| 941 |
}) |
|
| 942 | ||
| 943 | ! |
teal.widgets::table_with_settings_srv( |
| 944 | ! |
id = "table", |
| 945 | ! |
table_r = table_r |
| 946 |
) |
|
| 947 | ||
| 948 |
# Render R code. |
|
| 949 | ! |
teal.widgets::verbatim_popup_srv( |
| 950 | ! |
id = "rcode", |
| 951 | ! |
verbatim_content = reactive(teal.code::get_code(table_q())), |
| 952 | ! |
title = label |
| 953 |
) |
|
| 954 | ||
| 955 |
### REPORTER |
|
| 956 | ! |
if (with_reporter) {
|
| 957 | ! |
card_fun <- function(comment, label) {
|
| 958 | ! |
card <- teal::report_card_template( |
| 959 | ! |
title = "ANCOVA", |
| 960 | ! |
label = label, |
| 961 | ! |
description = "Analysis of Covariance", |
| 962 | ! |
with_filter = with_filter, |
| 963 | ! |
filter_panel_api = filter_panel_api |
| 964 |
) |
|
| 965 | ! |
card$append_text("Table", "header3")
|
| 966 | ! |
card$append_table(table_r()) |
| 967 | ! |
if (!comment == "") {
|
| 968 | ! |
card$append_text("Comment", "header3")
|
| 969 | ! |
card$append_text(comment) |
| 970 |
} |
|
| 971 | ! |
card$append_src(teal.code::get_code(table_q())) |
| 972 | ! |
card |
| 973 |
} |
|
| 974 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 975 |
} |
|
| 976 |
### |
|
| 977 |
}) |
|
| 978 |
} |
| 1 |
#' Template: Shift by Arm |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a summary table of analysis indicator levels by arm. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param aval_var (`character`)\cr name of the analysis reference range indicator variable. |
|
| 7 |
#' @param baseline_var (`character`)\cr name of the baseline reference range indicator variable. |
|
| 8 |
#' @param add_total (`logical`)\cr whether to include row with total number of patients. |
|
| 9 |
#' |
|
| 10 |
#' @inherit template_arguments return |
|
| 11 |
#' |
|
| 12 |
#' @seealso [tm_t_shift_by_arm()] |
|
| 13 |
#' |
|
| 14 |
#' @keywords internal |
|
| 15 |
template_shift_by_arm <- function(dataname, |
|
| 16 |
parentname, |
|
| 17 |
arm_var = "ARM", |
|
| 18 |
paramcd = "PARAMCD", |
|
| 19 |
visit_var = "AVISIT", |
|
| 20 |
treatment_flag_var = "ONTRTFL", |
|
| 21 |
treatment_flag = "Y", |
|
| 22 |
aval_var = "ANRIND", |
|
| 23 |
base_var = lifecycle::deprecated(), |
|
| 24 |
baseline_var = "BNRIND", |
|
| 25 |
na.rm = FALSE, # nolint: object_name. |
|
| 26 |
na_level = default_na_str(), |
|
| 27 |
add_total = FALSE, |
|
| 28 |
total_label = default_total_label(), |
|
| 29 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 30 | 3x |
if (lifecycle::is_present(base_var)) {
|
| 31 | ! |
baseline_var <- base_var |
| 32 | ! |
warning( |
| 33 | ! |
"The `base_var` argument of `template_shift_by_arm()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 34 | ! |
"Please use the `baseline_var` argument instead.", |
| 35 | ! |
call. = FALSE |
| 36 |
) |
|
| 37 |
} |
|
| 38 | ||
| 39 | 3x |
checkmate::assert_string(dataname) |
| 40 | 3x |
checkmate::assert_string(parentname) |
| 41 | 3x |
checkmate::assert_string(arm_var) |
| 42 | 3x |
checkmate::assert_string(visit_var) |
| 43 | 3x |
checkmate::assert_string(paramcd, na.ok = TRUE) |
| 44 | 3x |
checkmate::assert_string(aval_var) |
| 45 | 3x |
checkmate::assert_string(baseline_var) |
| 46 | 3x |
checkmate::assert_flag(na.rm) |
| 47 | 3x |
checkmate::assert_string(na_level) |
| 48 | 3x |
checkmate::assert_string(treatment_flag_var) |
| 49 | 3x |
checkmate::assert_string(treatment_flag) |
| 50 | 3x |
checkmate::assert_flag(add_total) |
| 51 | 3x |
checkmate::assert_string(total_label) |
| 52 | ||
| 53 | 3x |
y <- list() |
| 54 | ||
| 55 |
# Start data steps. |
|
| 56 | 3x |
data_list <- list() |
| 57 | 3x |
data_list <- add_expr( |
| 58 | 3x |
data_list, |
| 59 | 3x |
substitute( |
| 60 | 3x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 61 | 3x |
env = list(parentname = as.name(parentname), na_str = na_level) |
| 62 |
) |
|
| 63 |
) |
|
| 64 | 3x |
data_list <- add_expr( |
| 65 | 3x |
data_list, |
| 66 | 3x |
substitute( |
| 67 | 3x |
expr = dataname <- df_explicit_na(dataname, na_level = na_str) %>% |
| 68 | 3x |
dplyr::filter(treatment_flag_var == treatment_flag), |
| 69 | 3x |
env = list( |
| 70 | 3x |
dataname = as.name(dataname), |
| 71 | 3x |
na_str = na_level, |
| 72 | 3x |
treatment_flag_var = as.name(treatment_flag_var), |
| 73 | 3x |
treatment_flag = treatment_flag |
| 74 |
) |
|
| 75 |
) |
|
| 76 |
) |
|
| 77 | ||
| 78 | 3x |
data_list <- add_expr( |
| 79 | 3x |
data_list, |
| 80 | 3x |
substitute( |
| 81 | 3x |
expr = attr(dataname$baseline_var, "label") <- "Baseline Assessment", |
| 82 | 3x |
env = list(dataname = as.name(dataname), baseline_var = baseline_var) |
| 83 |
) |
|
| 84 |
) |
|
| 85 | ||
| 86 | 3x |
y$data <- bracket_expr(data_list) |
| 87 | ||
| 88 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 89 | 3x |
teal.widgets::resolve_basic_table_args( |
| 90 | 3x |
user_table = basic_table_args |
| 91 |
) |
|
| 92 |
) |
|
| 93 | ||
| 94 |
# Start layout steps. |
|
| 95 | 3x |
layout_list <- list() |
| 96 | ||
| 97 | 3x |
if (add_total) {
|
| 98 | 1x |
layout_list <- add_expr( |
| 99 | 1x |
layout_list, |
| 100 | 1x |
substitute( |
| 101 | 1x |
expr = expr_basic_table_args %>% |
| 102 | 1x |
rtables::split_cols_by(visit_var, split_fun = drop_split_levels) %>% # temp solution for over arching column |
| 103 | 1x |
rtables::split_cols_by(aval_var) %>% |
| 104 | 1x |
rtables::split_rows_by( |
| 105 | 1x |
arm_var, |
| 106 | 1x |
split_fun = add_overall_level(total_label, first = FALSE), |
| 107 | 1x |
label_pos = "topleft", |
| 108 | 1x |
split_label = obj_label(dataname$arm_var) |
| 109 |
) %>% |
|
| 110 | 1x |
add_rowcounts() %>% |
| 111 | 1x |
analyze_vars( |
| 112 | 1x |
baseline_var, |
| 113 | 1x |
denom = "N_row", |
| 114 | 1x |
na_str = na_str, |
| 115 | 1x |
na.rm = na.rm, |
| 116 | 1x |
.stats = "count_fraction" |
| 117 |
) %>% |
|
| 118 | 1x |
append_varlabels(dataname, baseline_var, indent = 1L), |
| 119 | 1x |
env = list( |
| 120 | 1x |
aval_var = aval_var, |
| 121 | 1x |
arm_var = arm_var, |
| 122 | 1x |
baseline_var = baseline_var, |
| 123 | 1x |
dataname = as.name(dataname), |
| 124 | 1x |
visit_var = visit_var, |
| 125 | 1x |
na.rm = na.rm, |
| 126 | 1x |
na_str = na_level, |
| 127 | 1x |
total_label = total_label, |
| 128 | 1x |
expr_basic_table_args = parsed_basic_table_args |
| 129 |
) |
|
| 130 |
) |
|
| 131 |
) |
|
| 132 |
} else {
|
|
| 133 | 2x |
layout_list <- add_expr( |
| 134 | 2x |
layout_list, |
| 135 | 2x |
substitute( |
| 136 | 2x |
expr = expr_basic_table_args %>% |
| 137 | 2x |
rtables::split_cols_by(visit_var, split_fun = drop_split_levels) %>% # temp solution for over arching column |
| 138 | 2x |
rtables::split_cols_by(aval_var) %>% |
| 139 | 2x |
rtables::split_rows_by( |
| 140 | 2x |
arm_var, |
| 141 | 2x |
split_fun = drop_split_levels, |
| 142 | 2x |
label_pos = "topleft", |
| 143 | 2x |
split_label = obj_label(dataname$arm_var) |
| 144 |
) %>% |
|
| 145 | 2x |
add_rowcounts() %>% |
| 146 | 2x |
analyze_vars( |
| 147 | 2x |
baseline_var, |
| 148 | 2x |
denom = "N_row", |
| 149 | 2x |
na_str = na_str, |
| 150 | 2x |
na.rm = na.rm, |
| 151 | 2x |
.stats = "count_fraction" |
| 152 |
) %>% |
|
| 153 | 2x |
append_varlabels(dataname, baseline_var, indent = 1L), |
| 154 | 2x |
env = list( |
| 155 | 2x |
aval_var = aval_var, |
| 156 | 2x |
arm_var = arm_var, |
| 157 | 2x |
baseline_var = baseline_var, |
| 158 | 2x |
dataname = as.name(dataname), |
| 159 | 2x |
visit_var = visit_var, |
| 160 | 2x |
na.rm = na.rm, |
| 161 | 2x |
na_str = na_level, |
| 162 | 2x |
expr_basic_table_args = parsed_basic_table_args |
| 163 |
) |
|
| 164 |
) |
|
| 165 |
) |
|
| 166 |
} |
|
| 167 | ||
| 168 | 3x |
y$layout <- substitute( |
| 169 | 3x |
expr = lyt <- layout_pipe, |
| 170 | 3x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 171 |
) |
|
| 172 | ||
| 173 |
# Full table. |
|
| 174 | 3x |
y$table <- substitute( |
| 175 | 3x |
expr = {
|
| 176 | ! |
result <- rtables::build_table(lyt = lyt, df = dataname) |
| 177 | ! |
result |
| 178 |
}, |
|
| 179 | 3x |
env = list(dataname = as.name(dataname)) |
| 180 |
) |
|
| 181 | ||
| 182 | 3x |
y |
| 183 |
} |
|
| 184 | ||
| 185 |
#' teal Module: Shift by Arm |
|
| 186 |
#' |
|
| 187 |
#' This module produces a summary table of analysis indicator levels by arm. |
|
| 188 |
#' |
|
| 189 |
#' @inheritParams module_arguments |
|
| 190 |
#' @inheritParams template_shift_by_arm |
|
| 191 |
#' |
|
| 192 |
#' @inherit module_arguments return seealso |
|
| 193 |
#' |
|
| 194 |
#' @examples |
|
| 195 |
#' ADSL <- tmc_ex_adsl |
|
| 196 |
#' ADEG <- tmc_ex_adeg |
|
| 197 |
#' |
|
| 198 |
#' app <- init( |
|
| 199 |
#' data = cdisc_data( |
|
| 200 |
#' ADSL = ADSL, |
|
| 201 |
#' ADEG = ADEG, |
|
| 202 |
#' code = " |
|
| 203 |
#' ADSL <- tmc_ex_adsl |
|
| 204 |
#' ADEG <- tmc_ex_adeg |
|
| 205 |
#' " |
|
| 206 |
#' ), |
|
| 207 |
#' modules = modules( |
|
| 208 |
#' tm_t_shift_by_arm( |
|
| 209 |
#' label = "Shift by Arm Table", |
|
| 210 |
#' dataname = "ADEG", |
|
| 211 |
#' arm_var = choices_selected( |
|
| 212 |
#' variable_choices(ADSL, subset = c("ARM", "ARMCD")),
|
|
| 213 |
#' selected = "ARM" |
|
| 214 |
#' ), |
|
| 215 |
#' paramcd = choices_selected( |
|
| 216 |
#' value_choices(ADEG, "PARAMCD"), |
|
| 217 |
#' selected = "HR" |
|
| 218 |
#' ), |
|
| 219 |
#' visit_var = choices_selected( |
|
| 220 |
#' value_choices(ADEG, "AVISIT"), |
|
| 221 |
#' selected = "POST-BASELINE MINIMUM" |
|
| 222 |
#' ), |
|
| 223 |
#' aval_var = choices_selected( |
|
| 224 |
#' variable_choices(ADEG, subset = "ANRIND"), |
|
| 225 |
#' selected = "ANRIND", fixed = TRUE |
|
| 226 |
#' ), |
|
| 227 |
#' baseline_var = choices_selected( |
|
| 228 |
#' variable_choices(ADEG, subset = "BNRIND"), |
|
| 229 |
#' selected = "BNRIND", fixed = TRUE |
|
| 230 |
#' ), |
|
| 231 |
#' useNA = "ifany" |
|
| 232 |
#' ) |
|
| 233 |
#' ) |
|
| 234 |
#' ) |
|
| 235 |
#' if (interactive()) {
|
|
| 236 |
#' shinyApp(app$ui, app$server) |
|
| 237 |
#' } |
|
| 238 |
#' |
|
| 239 |
#' @export |
|
| 240 |
tm_t_shift_by_arm <- function(label, |
|
| 241 |
dataname, |
|
| 242 |
parentname = ifelse( |
|
| 243 |
inherits(arm_var, "data_extract_spec"), |
|
| 244 |
teal.transform::datanames_input(arm_var), |
|
| 245 |
"ADSL" |
|
| 246 |
), |
|
| 247 |
arm_var, |
|
| 248 |
paramcd, |
|
| 249 |
visit_var, |
|
| 250 |
aval_var, |
|
| 251 |
base_var = lifecycle::deprecated(), |
|
| 252 |
baseline_var, |
|
| 253 |
treatment_flag_var = teal.transform::choices_selected( |
|
| 254 |
teal.transform::variable_choices(dataname, subset = "ONTRTFL"), |
|
| 255 |
selected = "ONTRTFL" |
|
| 256 |
), |
|
| 257 |
treatment_flag = teal.transform::choices_selected("Y"),
|
|
| 258 |
useNA = c("ifany", "no"), # nolint: object_name.
|
|
| 259 |
na_level = default_na_str(), |
|
| 260 |
add_total = FALSE, |
|
| 261 |
total_label = default_total_label(), |
|
| 262 |
pre_output = NULL, |
|
| 263 |
post_output = NULL, |
|
| 264 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 265 | ! |
if (lifecycle::is_present(base_var)) {
|
| 266 | ! |
baseline_var <- base_var |
| 267 | ! |
warning( |
| 268 | ! |
"The `base_var` argument of `tm_t_shift_by_arm()` is deprecated as of teal.modules.clinical 0.8.16. ", |
| 269 | ! |
"Please use the `baseline_var` argument instead.", |
| 270 | ! |
call. = FALSE |
| 271 |
) |
|
| 272 |
} else {
|
|
| 273 | ! |
base_var <- baseline_var # resolves missing argument error |
| 274 |
} |
|
| 275 | ||
| 276 | ! |
message("Initializing tm_t_shift_by_arm")
|
| 277 | ! |
checkmate::assert_string(label) |
| 278 | ! |
checkmate::assert_string(dataname) |
| 279 | ! |
checkmate::assert_string(parentname) |
| 280 | ! |
useNA <- match.arg(useNA) # nolint: object_name. |
| 281 | ! |
checkmate::assert_string(na_level) |
| 282 | ! |
checkmate::assert_string(total_label) |
| 283 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 284 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 285 | ! |
checkmate::assert_class(visit_var, "choices_selected") |
| 286 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 287 | ! |
checkmate::assert_class(baseline_var, "choices_selected") |
| 288 | ! |
checkmate::assert_class(treatment_flag_var, "choices_selected") |
| 289 | ! |
checkmate::assert_class(treatment_flag, "choices_selected") |
| 290 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 291 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 292 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 293 | ||
| 294 | ! |
args <- as.list(environment()) |
| 295 | ||
| 296 | ! |
data_extract_list <- list( |
| 297 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 298 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 299 | ! |
visit_var = cs_to_des_filter(visit_var, dataname = dataname), |
| 300 | ! |
treatment_flag_var = cs_to_des_select(treatment_flag_var, dataname = dataname), |
| 301 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 302 | ! |
baseline_var = cs_to_des_select(baseline_var, dataname = dataname) |
| 303 |
) |
|
| 304 | ||
| 305 | ! |
module( |
| 306 | ! |
label = label, |
| 307 | ! |
server = srv_shift_by_arm, |
| 308 | ! |
ui = ui_shift_by_arm, |
| 309 | ! |
ui_args = c(data_extract_list, args), |
| 310 | ! |
server_args = c( |
| 311 | ! |
data_extract_list, |
| 312 | ! |
list( |
| 313 | ! |
dataname = dataname, |
| 314 | ! |
parentname = parentname, |
| 315 | ! |
label = label, |
| 316 | ! |
total_label = total_label, |
| 317 | ! |
na_level = na_level, |
| 318 | ! |
treatment_flag = treatment_flag, |
| 319 | ! |
basic_table_args = basic_table_args |
| 320 |
) |
|
| 321 |
), |
|
| 322 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 323 |
) |
|
| 324 |
} |
|
| 325 | ||
| 326 |
#' @keywords internal |
|
| 327 |
ui_shift_by_arm <- function(id, ...) {
|
|
| 328 | ! |
ns <- NS(id) |
| 329 | ! |
a <- list(...) |
| 330 | ||
| 331 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 332 | ! |
a$id_var, |
| 333 | ! |
a$arm_var, |
| 334 | ! |
a$paramcd, |
| 335 | ! |
a$visit_var, |
| 336 | ! |
a$treatment_flag_var, |
| 337 | ! |
a$treatment_flag, |
| 338 | ! |
a$aval_var, |
| 339 | ! |
a$baseline_var |
| 340 |
) |
|
| 341 | ||
| 342 | ! |
teal.widgets::standard_layout( |
| 343 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 344 | ! |
encoding = tags$div( |
| 345 |
### Reporter |
|
| 346 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 347 |
### |
|
| 348 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 349 | ! |
teal.transform::datanames_input(a[c( |
| 350 | ! |
"arm_var", "paramcd_var", "paramcd", "aval_var", "baseline_var", "visit_var", "treamtment_flag_var" |
| 351 |
)]), |
|
| 352 | ! |
teal.transform::data_extract_ui( |
| 353 | ! |
id = ns("arm_var"),
|
| 354 | ! |
label = "Select Treatment Variable", |
| 355 | ! |
data_extract_spec = a$arm_var, |
| 356 | ! |
is_single_dataset = is_single_dataset_value |
| 357 |
), |
|
| 358 | ! |
teal.transform::data_extract_ui( |
| 359 | ! |
id = ns("paramcd"),
|
| 360 | ! |
label = "Select Endpoint", |
| 361 | ! |
data_extract_spec = a$paramcd, |
| 362 | ! |
is_single_dataset = is_single_dataset_value |
| 363 |
), |
|
| 364 | ! |
teal.transform::data_extract_ui( |
| 365 | ! |
id = ns("visit_var"),
|
| 366 | ! |
label = "Select Visit", |
| 367 | ! |
data_extract_spec = a$visit_var, |
| 368 | ! |
is_single_dataset = is_single_dataset_value |
| 369 |
), |
|
| 370 | ! |
teal.transform::data_extract_ui( |
| 371 | ! |
id = ns("aval_var"),
|
| 372 | ! |
label = "Select Analysis Range Indicator Variable", |
| 373 | ! |
data_extract_spec = a$aval_var, |
| 374 | ! |
is_single_dataset = is_single_dataset_value |
| 375 |
), |
|
| 376 | ! |
teal.transform::data_extract_ui( |
| 377 | ! |
id = ns("baseline_var"),
|
| 378 | ! |
label = "Select Baseline Reference Range Indicator Variable", |
| 379 | ! |
data_extract_spec = a$baseline_var, |
| 380 | ! |
is_single_dataset = is_single_dataset_value |
| 381 |
), |
|
| 382 | ! |
checkboxInput(ns("add_total"), "Add All Patients row", value = a$add_total),
|
| 383 | ! |
radioButtons( |
| 384 | ! |
ns("useNA"),
|
| 385 | ! |
label = "Display NA counts", |
| 386 | ! |
choices = c("ifany", "no"),
|
| 387 | ! |
selected = a$useNA |
| 388 |
), |
|
| 389 | ! |
teal.widgets::panel_group( |
| 390 | ! |
teal.widgets::panel_item( |
| 391 | ! |
"Additional Variables Info", |
| 392 | ! |
teal.transform::data_extract_ui( |
| 393 | ! |
id = ns("treatment_flag_var"),
|
| 394 | ! |
label = "On Treatment Flag Variable", |
| 395 | ! |
data_extract_spec = a$treatment_flag_var, |
| 396 | ! |
is_single_dataset = is_single_dataset_value |
| 397 |
), |
|
| 398 | ! |
teal.widgets::optionalSelectInput( |
| 399 | ! |
ns("treatment_flag"),
|
| 400 | ! |
label = "Value Indicating On Treatment", |
| 401 | ! |
multiple = FALSE, |
| 402 | ! |
fixed_on_single = TRUE |
| 403 |
) |
|
| 404 |
) |
|
| 405 |
) |
|
| 406 |
), |
|
| 407 | ! |
forms = tagList( |
| 408 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 409 |
), |
|
| 410 | ! |
pre_output = a$pre_output, |
| 411 | ! |
post_output = a$post_output |
| 412 |
) |
|
| 413 |
} |
|
| 414 | ||
| 415 |
#' @keywords internal |
|
| 416 |
srv_shift_by_arm <- function(id, |
|
| 417 |
data, |
|
| 418 |
reporter, |
|
| 419 |
filter_panel_api, |
|
| 420 |
dataname, |
|
| 421 |
parentname, |
|
| 422 |
arm_var, |
|
| 423 |
paramcd, |
|
| 424 |
visit_var, |
|
| 425 |
treatment_flag_var, |
|
| 426 |
treatment_flag, |
|
| 427 |
aval_var, |
|
| 428 |
baseline_var, |
|
| 429 |
label, |
|
| 430 |
na_level, |
|
| 431 |
add_total, |
|
| 432 |
total_label, |
|
| 433 |
basic_table_args) {
|
|
| 434 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 435 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 436 | ! |
checkmate::assert_class(data, "reactive") |
| 437 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 438 | ! |
moduleServer(id, function(input, output, session) {
|
| 439 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 440 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 441 | ! |
data_extract = list( |
| 442 | ! |
arm_var = arm_var, |
| 443 | ! |
paramcd = paramcd, |
| 444 | ! |
visit_var = visit_var, |
| 445 | ! |
aval_var = aval_var, |
| 446 | ! |
baseline_var = baseline_var, |
| 447 | ! |
treatment_flag_var = treatment_flag_var |
| 448 |
), |
|
| 449 | ! |
datasets = data, |
| 450 | ! |
select_validation_rule = list( |
| 451 | ! |
aval_var = shinyvalidate::sv_required("An analysis range indicator required"),
|
| 452 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required"),
|
| 453 | ! |
treatment_flag_var = shinyvalidate::sv_required("An on treatment flag variable is required"),
|
| 454 | ! |
baseline_var = shinyvalidate::sv_required("A baseline reference range indicator is required")
|
| 455 |
), |
|
| 456 | ! |
filter_validation_rule = list( |
| 457 | ! |
paramcd = shinyvalidate::sv_required("An endpoint is required"),
|
| 458 | ! |
visit_var = shinyvalidate::sv_required("A visit is required")
|
| 459 |
) |
|
| 460 |
) |
|
| 461 | ||
| 462 | ! |
isolate({
|
| 463 | ! |
resolved <- teal.transform::resolve_delayed(treatment_flag, as.list(data()@env)) |
| 464 | ! |
teal.widgets::updateOptionalSelectInput( |
| 465 | ! |
session = session, |
| 466 | ! |
inputId = "treatment_flag", |
| 467 | ! |
choices = resolved$choices, |
| 468 | ! |
selected = resolved$selected |
| 469 |
) |
|
| 470 |
}) |
|
| 471 | ||
| 472 | ! |
iv_r <- reactive({
|
| 473 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 474 | ! |
iv$add_rule( |
| 475 | ! |
"treatment_flag", |
| 476 | ! |
shinyvalidate::sv_required("An indicator value for on treatment records is required")
|
| 477 |
) |
|
| 478 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 479 |
}) |
|
| 480 | ||
| 481 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 482 | ! |
datasets = data, |
| 483 | ! |
selector_list = selector_list, |
| 484 | ! |
merge_function = "dplyr::inner_join" |
| 485 |
) |
|
| 486 | ||
| 487 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 488 | ! |
datasets = data, |
| 489 | ! |
data_extract = list(arm_var = arm_var), |
| 490 | ! |
anl_name = "ANL_ADSL" |
| 491 |
) |
|
| 492 | ||
| 493 | ! |
anl_q <- reactive({
|
| 494 | ! |
data() %>% |
| 495 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 496 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 497 |
}) |
|
| 498 | ||
| 499 | ! |
merged <- list( |
| 500 | ! |
anl_input_r = anl_inputs, |
| 501 | ! |
adsl_input_r = adsl_inputs, |
| 502 | ! |
anl_q = anl_q |
| 503 |
) |
|
| 504 | ||
| 505 |
# validate inputs |
|
| 506 | ! |
validate_checks <- reactive({
|
| 507 | ! |
teal::validate_inputs(iv_r()) |
| 508 | ||
| 509 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 510 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 511 | ||
| 512 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 513 | ! |
input_aval_var <- names(merged$anl_input_r()$columns_source$aval_var) |
| 514 | ! |
input_baseline_var <- names(merged$anl_input_r()$columns_source$baseline_var) |
| 515 | ! |
input_treatment_flag_var <- names(merged$anl_input_r()$columns_source$treatment_flag_var) |
| 516 | ||
| 517 | ! |
validate( |
| 518 | ! |
need( |
| 519 | ! |
nrow(merged$anl_q()[["ANL"]]) > 0, |
| 520 | ! |
paste0( |
| 521 | ! |
"Please make sure the analysis dataset is not empty or\n", |
| 522 | ! |
"endpoint parameter and analysis visit are selected." |
| 523 |
) |
|
| 524 |
) |
|
| 525 |
) |
|
| 526 | ||
| 527 | ! |
validate_standard_inputs( |
| 528 | ! |
adsl = adsl_filtered, |
| 529 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 530 | ! |
anl = anl_filtered, |
| 531 | ! |
anlvars = c("USUBJID", "STUDYID", input_aval_var, input_baseline_var),
|
| 532 | ! |
arm_var = input_arm_var |
| 533 |
) |
|
| 534 |
}) |
|
| 535 | ||
| 536 |
# generate r code for the analysis |
|
| 537 | ! |
all_q <- reactive({
|
| 538 | ! |
validate_checks() |
| 539 | ||
| 540 | ! |
my_calls <- template_shift_by_arm( |
| 541 | ! |
dataname = "ANL", |
| 542 | ! |
parentname = "ANL_ADSL", |
| 543 | ! |
arm_var = names(merged$anl_input_r()$columns_source$arm_var), |
| 544 | ! |
paramcd = unlist(merged$anl_input_r()$filter)["vars_selected"], |
| 545 | ! |
treatment_flag_var = names(merged$anl_input_r()$columns_source$treatment_flag_var), |
| 546 | ! |
treatment_flag = input$treatment_flag, |
| 547 | ! |
aval_var = names(merged$anl_input_r()$columns_source$aval_var), |
| 548 | ! |
baseline_var = names(merged$anl_input_r()$columns_source$baseline_var), |
| 549 | ! |
na.rm = ifelse(input$useNA == "ifany", FALSE, TRUE), |
| 550 | ! |
na_level = na_level, |
| 551 | ! |
add_total = input$add_total, |
| 552 | ! |
total_label = total_label, |
| 553 | ! |
basic_table_args = basic_table_args |
| 554 |
) |
|
| 555 | ||
| 556 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 557 |
}) |
|
| 558 | ||
| 559 |
# Outputs to render. |
|
| 560 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 561 | ||
| 562 | ! |
teal.widgets::table_with_settings_srv( |
| 563 | ! |
id = "table", |
| 564 | ! |
table_r = table_r |
| 565 |
) |
|
| 566 | ||
| 567 |
# Render R code. |
|
| 568 | ! |
teal.widgets::verbatim_popup_srv( |
| 569 | ! |
id = "rcode", |
| 570 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 571 | ! |
title = label |
| 572 |
) |
|
| 573 | ||
| 574 |
### REPORTER |
|
| 575 | ! |
if (with_reporter) {
|
| 576 | ! |
card_fun <- function(comment, label) {
|
| 577 | ! |
card <- teal::report_card_template( |
| 578 | ! |
title = "Shift by Arm Table", |
| 579 | ! |
label = label, |
| 580 | ! |
with_filter = with_filter, |
| 581 | ! |
filter_panel_api = filter_panel_api |
| 582 |
) |
|
| 583 | ! |
card$append_text("Table", "header3")
|
| 584 | ! |
card$append_table(table_r()) |
| 585 | ! |
if (!comment == "") {
|
| 586 | ! |
card$append_text("Comment", "header3")
|
| 587 | ! |
card$append_text(comment) |
| 588 |
} |
|
| 589 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 590 | ! |
card |
| 591 |
} |
|
| 592 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 593 |
} |
|
| 594 |
### |
|
| 595 |
}) |
|
| 596 |
} |
| 1 |
#' Parse text input to numeric vector |
|
| 2 |
#' |
|
| 3 |
#' Generic to parse text into numeric vectors. This was initially designed |
|
| 4 |
#' for a robust interpretation of text input in teal modules. |
|
| 5 |
#' |
|
| 6 |
#' @param str (`vector`)\cr to extract numeric from. |
|
| 7 |
#' @details The function is intended to extract any numeric from a character |
|
| 8 |
#' string, factor levels, boolean and return a vector of numeric. |
|
| 9 |
#' |
|
| 10 |
#' @md |
|
| 11 |
#' |
|
| 12 |
#' @return As vector of numeric if directly parsed from `numeric` or boolean. |
|
| 13 |
#' A list of numeric if parsed from a character string, each character string |
|
| 14 |
#' associated with an list item. |
|
| 15 |
#' |
|
| 16 |
#' @examples |
|
| 17 |
#' dta <- list( |
|
| 18 |
#' character = c("text10,20.5letter30.!", "!-.40$$-50e5[", NA),
|
|
| 19 |
#' factor = factor(c("]+60e-6, 7.7%%8L", "%90sep.100\"1L", NA_character_)),
|
|
| 20 |
#' numeric = c(1, -5e+2, NA), |
|
| 21 |
#' logical = c(TRUE, FALSE, NA) |
|
| 22 |
#' ) |
|
| 23 |
#' lapply(dta, as_num) |
|
| 24 |
#' @export |
|
| 25 |
as_num <- function(str) {
|
|
| 26 | 5x |
UseMethod("as_num")
|
| 27 |
} |
|
| 28 | ||
| 29 |
#' @export |
|
| 30 |
#' @rdname as_num |
|
| 31 |
as_num.default <- function(str) {
|
|
| 32 | ! |
stop("No default implementation for `as_num.default`.")
|
| 33 |
} |
|
| 34 | ||
| 35 |
#' @export |
|
| 36 |
#' @rdname as_num |
|
| 37 |
as_num.character <- function(str) {
|
|
| 38 | 2x |
y <- regmatches( |
| 39 | 2x |
x = str, |
| 40 | 2x |
m = gregexpr( |
| 41 | 2x |
"[-+]?(\\d+(\\.\\d*)?|\\.\\d+)([eE][-+]?\\d+)?", |
| 42 | 2x |
str, |
| 43 | 2x |
perl = TRUE |
| 44 |
) |
|
| 45 |
) |
|
| 46 | ||
| 47 | 2x |
y <- lapply(y, as.numeric) |
| 48 | 2x |
y[unlist(lapply(y, length) == 0)] <- NA |
| 49 | ||
| 50 | 2x |
return(y) |
| 51 |
} |
|
| 52 | ||
| 53 |
#' @export |
|
| 54 |
#' @rdname as_num |
|
| 55 |
as_num.numeric <- function(str) {
|
|
| 56 | 1x |
return(str) |
| 57 |
} |
|
| 58 | ||
| 59 |
#' @export |
|
| 60 |
#' @rdname as_num |
|
| 61 |
as_num.factor <- function(str) {
|
|
| 62 | 1x |
y <- as.character(str) |
| 63 | 1x |
y <- as_num(y) |
| 64 | 1x |
return(y) |
| 65 |
} |
|
| 66 | ||
| 67 |
#' @export |
|
| 68 |
#' @rdname as_num |
|
| 69 |
as_num.logical <- function(str) {
|
|
| 70 | 1x |
y <- as.numeric(str) |
| 71 | 1x |
return(y) |
| 72 |
} |
| 1 |
#' Template: Adverse Events Summary |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate an adverse events summary table. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param dthfl_var (`character`)\cr name of variable for subject death flag from `parentname`. |
|
| 7 |
#' Records with `"Y"` are summarized in the table row for "Total number of deaths". |
|
| 8 |
#' @param dcsreas_var (`character`)\cr name of variable for study discontinuation reason from `parentname`. |
|
| 9 |
#' Records with `"ADVERSE EVENTS"` are summarized in the table row for |
|
| 10 |
#' "Total number of patients withdrawn from study due to an AE". |
|
| 11 |
#' @param flag_var_anl (`character`)\cr name of flag variable from `dataset` used to count adverse event sub-groups |
|
| 12 |
#' (e.g. Serious events, Related events, etc.). Variable labels are used as table row names if they exist. |
|
| 13 |
#' @param flag_var_aesi (`character`)\cr name of flag variable from `dataset` used to count adverse event special |
|
| 14 |
#' interest groups. All flag variables must be of type `logical`. Variable labels are used as table row names if |
|
| 15 |
#' they exist. |
|
| 16 |
#' @param aeseq_var (`character`)\cr name of variable for adverse events sequence number from `dataset`. Used for |
|
| 17 |
#' counting total number of events. |
|
| 18 |
#' @param count_dth (`logical`)\cr whether to show count of total deaths (based on `dthfl_var`). Defaults to `TRUE`. |
|
| 19 |
#' @param count_wd (`logical`)\cr whether to show count of patients withdrawn from study due to an adverse event |
|
| 20 |
#' (based on `dcsreas_var`). Defaults to `TRUE`. |
|
| 21 |
#' @param count_subj (`logical`)\cr whether to show count of unique subjects (based on `USUBJID`). Only applies if |
|
| 22 |
#' event flag variables are provided. |
|
| 23 |
#' @param count_pt (`logical`)\cr whether to show count of unique preferred terms (based on `llt`). Only applies if |
|
| 24 |
#' event flag variables are provided. |
|
| 25 |
#' @param count_events (`logical`)\cr whether to show count of events (based on `aeseq_var`). Only applies if event |
|
| 26 |
#' flag variables are provided. |
|
| 27 |
#' |
|
| 28 |
#' @inherit template_arguments return |
|
| 29 |
#' |
|
| 30 |
#' @seealso [tm_t_events_summary()] |
|
| 31 |
#' |
|
| 32 |
#' @keywords internal |
|
| 33 |
template_events_summary <- function(anl_name, |
|
| 34 |
parentname, |
|
| 35 |
arm_var, |
|
| 36 |
dthfl_var = "DTHFL", |
|
| 37 |
dcsreas_var = "DCSREAS", |
|
| 38 |
flag_var_anl = NULL, |
|
| 39 |
flag_var_aesi = NULL, |
|
| 40 |
aeseq_var = "AESEQ", |
|
| 41 |
llt = "AEDECOD", |
|
| 42 |
add_total = TRUE, |
|
| 43 |
total_label = default_total_label(), |
|
| 44 |
na_level = default_na_str(), |
|
| 45 |
count_dth = TRUE, |
|
| 46 |
count_wd = TRUE, |
|
| 47 |
count_subj = TRUE, |
|
| 48 |
count_pt = TRUE, |
|
| 49 |
count_events = TRUE) {
|
|
| 50 | 2x |
checkmate::assert_string(anl_name) |
| 51 | 2x |
checkmate::assert_string(parentname) |
| 52 | 2x |
checkmate::assert_character(arm_var, min.len = 1, max.len = 2) |
| 53 | 2x |
checkmate::assert_string(dthfl_var) |
| 54 | 2x |
checkmate::assert_string(dcsreas_var) |
| 55 | 2x |
checkmate::assert_flag(add_total) |
| 56 | 2x |
checkmate::assert_string(total_label) |
| 57 | 2x |
checkmate::assert_string(na_level) |
| 58 | 2x |
checkmate::assert_character(flag_var_anl, null.ok = TRUE) |
| 59 | 2x |
checkmate::assert_character(flag_var_aesi, null.ok = TRUE) |
| 60 | 2x |
checkmate::assert_string(aeseq_var) |
| 61 | 2x |
checkmate::assert_string(llt) |
| 62 | 2x |
checkmate::assert_flag(count_dth) |
| 63 | 2x |
checkmate::assert_flag(count_wd) |
| 64 | 2x |
checkmate::assert_flag(count_subj) |
| 65 | 2x |
checkmate::assert_flag(count_pt) |
| 66 | 2x |
checkmate::assert_flag(count_events) |
| 67 | ||
| 68 | 2x |
y <- list() |
| 69 | ||
| 70 | 2x |
data_list <- list() |
| 71 | 2x |
data_list <- add_expr( |
| 72 | 2x |
data_list, |
| 73 | 2x |
substitute( |
| 74 | 2x |
expr = anl <- anl_name, |
| 75 | 2x |
env = list(anl_name = as.name(anl_name)) |
| 76 |
) |
|
| 77 |
) |
|
| 78 | ||
| 79 |
# Since this is a compound table with one layout based on `parentname` |
|
| 80 |
# and one layout on `dataname`, columns will be filtered to match levels |
|
| 81 |
# present in `parentname` only so `drop_arm_levels` = FALSE. |
|
| 82 | 2x |
data_list <- add_expr( |
| 83 | 2x |
data_list, |
| 84 | 2x |
prepare_arm_levels( |
| 85 | 2x |
dataname = "anl", |
| 86 | 2x |
parentname = parentname, |
| 87 | 2x |
arm_var = arm_var[[1]], |
| 88 | 2x |
drop_arm_levels = FALSE |
| 89 |
) |
|
| 90 |
) |
|
| 91 | 2x |
if (length(arm_var) == 2) {
|
| 92 | ! |
data_list <- add_expr( |
| 93 | ! |
data_list, |
| 94 | ! |
prepare_arm_levels( |
| 95 | ! |
dataname = "anl", |
| 96 | ! |
parentname = parentname, |
| 97 | ! |
arm_var = arm_var[[2]], |
| 98 | ! |
drop_arm_levels = FALSE |
| 99 |
) |
|
| 100 |
) |
|
| 101 |
} |
|
| 102 | ||
| 103 | 2x |
data_list <- add_expr( |
| 104 | 2x |
data_list, |
| 105 | 2x |
quote(study_id <- unique(anl[["STUDYID"]])) |
| 106 |
) |
|
| 107 | ||
| 108 |
# Create dummy variable for counting patients with an AE |
|
| 109 | 2x |
data_list <- add_expr( |
| 110 | 2x |
data_list, |
| 111 | 2x |
quote(anl$tmp_aefl <- "Y") |
| 112 |
) |
|
| 113 | ||
| 114 | 2x |
data_list <- add_expr( |
| 115 | 2x |
data_list, |
| 116 | 2x |
substitute( |
| 117 | 2x |
expr = {
|
| 118 | ! |
anl[[a]] <- as.character(anl[[a]]) |
| 119 | ! |
anl <- anl %>% |
| 120 | ! |
dplyr::mutate( |
| 121 | ! |
USUBJID_AESEQ = paste(usubjid, aeseq_var, sep = "@@") |
| 122 |
) |
|
| 123 |
}, |
|
| 124 | 2x |
env = list( |
| 125 | 2x |
a = llt, |
| 126 | 2x |
usubjid = as.name("USUBJID"),
|
| 127 | 2x |
aeseq_var = as.name(aeseq_var) |
| 128 |
) |
|
| 129 |
) |
|
| 130 |
) |
|
| 131 | ||
| 132 | 2x |
if (length(flag_var_anl) > 0) {
|
| 133 | 1x |
data_list <- add_expr( |
| 134 | 1x |
data_list, |
| 135 | 1x |
substitute( |
| 136 | 1x |
flag_var_anl_label <- teal.data::col_labels(anl[, flag_var_anl], fill = FALSE), |
| 137 | 1x |
env = list(flag_var_anl = flag_var_anl) |
| 138 |
) |
|
| 139 |
) |
|
| 140 |
} |
|
| 141 | ||
| 142 | 2x |
if (length(flag_var_aesi) > 0) {
|
| 143 | 1x |
data_list <- add_expr( |
| 144 | 1x |
data_list, |
| 145 | 1x |
substitute( |
| 146 | 1x |
flag_var_aesi_label <- teal.data::col_labels(anl[, flag_var_aesi], fill = FALSE), |
| 147 | 1x |
env = list(flag_var_aesi = flag_var_aesi) |
| 148 |
) |
|
| 149 |
) |
|
| 150 |
} |
|
| 151 | ||
| 152 | 2x |
data_list <- add_expr( |
| 153 | 2x |
data_list, |
| 154 | 2x |
substitute( |
| 155 | 2x |
expr = dataname <- df_explicit_na(dataname, na_level = na_str), |
| 156 | 2x |
env = list(dataname = as.name("anl"), na_str = na_level)
|
| 157 |
) |
|
| 158 |
) |
|
| 159 | 2x |
data_list <- add_expr( |
| 160 | 2x |
data_list, |
| 161 | 2x |
substitute( |
| 162 | 2x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 163 | 2x |
env = list(parentname = as.name(parentname), na_str = na_level) |
| 164 |
) |
|
| 165 |
) |
|
| 166 | ||
| 167 | 2x |
y$data <- bracket_expr(data_list) |
| 168 | ||
| 169 |
# Layout to be used with `parentname` dataset |
|
| 170 |
# because not all subjects may exist in `anl_name` dataset. |
|
| 171 | 2x |
layout_parent_list <- list() |
| 172 | 2x |
layout_parent_list <- add_expr( |
| 173 | 2x |
layout_parent_list, |
| 174 | 2x |
quote(rtables::basic_table(show_colcounts = TRUE)) |
| 175 |
) |
|
| 176 | ||
| 177 | 2x |
layout_parent_list <- add_expr( |
| 178 | 2x |
layout_parent_list, |
| 179 | 2x |
substitute( |
| 180 | 2x |
expr = rtables::split_cols_by(var = arm_var), |
| 181 | 2x |
env = list(arm_var = arm_var[[1]]) |
| 182 |
) |
|
| 183 |
) |
|
| 184 | 2x |
if (length(arm_var) == 2) {
|
| 185 | ! |
layout_parent_list <- add_expr( |
| 186 | ! |
layout_parent_list, |
| 187 | ! |
substitute( |
| 188 | ! |
expr = rtables::split_cols_by(nested_col, split_fun = drop_split_levels), |
| 189 | ! |
env = list(nested_col = arm_var[[2]]) |
| 190 |
) |
|
| 191 |
) |
|
| 192 |
} |
|
| 193 | ||
| 194 | 2x |
if (add_total) {
|
| 195 | 2x |
layout_parent_list <- add_expr( |
| 196 | 2x |
layout_parent_list, |
| 197 | 2x |
substitute( |
| 198 | 2x |
expr = rtables::add_overall_col(label = total_label), |
| 199 | 2x |
env = list(total_label = total_label) |
| 200 |
) |
|
| 201 |
) |
|
| 202 |
} |
|
| 203 | ||
| 204 | 2x |
if (count_dth) {
|
| 205 | 1x |
layout_parent_list <- add_expr( |
| 206 | 1x |
layout_parent_list, |
| 207 | 1x |
substitute( |
| 208 | 1x |
expr = count_values( |
| 209 | 1x |
dthfl_var, |
| 210 | 1x |
values = "Y", |
| 211 | 1x |
.labels = c(count_fraction = "Total number of deaths"), |
| 212 | 1x |
.formats = c(count_fraction = format_count_fraction), |
| 213 | 1x |
denom = "N_col" |
| 214 |
), |
|
| 215 | 1x |
env = list(dthfl_var = dthfl_var) |
| 216 |
) |
|
| 217 |
) |
|
| 218 |
} |
|
| 219 | ||
| 220 | 2x |
if (count_wd) {
|
| 221 | 1x |
layout_parent_list <- add_expr( |
| 222 | 1x |
layout_parent_list, |
| 223 | 1x |
substitute( |
| 224 | 1x |
expr = count_values( |
| 225 | 1x |
dcsreas_var, |
| 226 | 1x |
values = "ADVERSE EVENT", |
| 227 | 1x |
.labels = c(count_fraction = "Total number of patients withdrawn from study due to an AE"), |
| 228 | 1x |
.formats = c(count_fraction = format_count_fraction), |
| 229 | 1x |
denom = "N_col" |
| 230 |
), |
|
| 231 | 1x |
env = list(dcsreas_var = dcsreas_var) |
| 232 |
) |
|
| 233 |
) |
|
| 234 |
} |
|
| 235 | ||
| 236 | 2x |
y$layout_parent <- substitute( |
| 237 | 2x |
expr = lyt_parent <- layout_parent_pipe, |
| 238 | 2x |
env = list( |
| 239 | 2x |
layout_parent_pipe = pipe_expr(layout_parent_list) |
| 240 |
) |
|
| 241 |
) |
|
| 242 | ||
| 243 | 2x |
table_parent_list <- list() |
| 244 | 2x |
table_parent_list <- add_expr( |
| 245 | 2x |
table_parent_list, |
| 246 | 2x |
substitute( |
| 247 | 2x |
expr = result_parent <- rtables::build_table(lyt = lyt_parent, df = df_parent, alt_counts_df = df_parent), |
| 248 | 2x |
env = list(df_parent = as.name(parentname)) |
| 249 |
) |
|
| 250 |
) |
|
| 251 | 2x |
y$table_parent <- pipe_expr(table_parent_list) |
| 252 | ||
| 253 | 2x |
layout_anl_list <- list() |
| 254 | 2x |
layout_anl_list <- add_expr( |
| 255 | 2x |
layout_anl_list, |
| 256 | 2x |
quote(rtables::basic_table(show_colcounts = TRUE)) |
| 257 |
) |
|
| 258 | ||
| 259 | 2x |
layout_anl_list <- add_expr( |
| 260 | 2x |
layout_anl_list, |
| 261 | 2x |
substitute( |
| 262 | 2x |
expr = rtables::split_cols_by(var = arm_var), |
| 263 | 2x |
env = list(arm_var = arm_var[[1]]) |
| 264 |
) |
|
| 265 |
) |
|
| 266 | 2x |
if (length(arm_var) == 2) {
|
| 267 | ! |
layout_anl_list <- add_expr( |
| 268 | ! |
layout_anl_list, |
| 269 | ! |
substitute( |
| 270 | ! |
expr = rtables::split_cols_by(nested_col, split_fun = drop_split_levels), |
| 271 | ! |
env = list(nested_col = arm_var[[2]]) |
| 272 |
) |
|
| 273 |
) |
|
| 274 |
} |
|
| 275 | ||
| 276 | 2x |
if (add_total) {
|
| 277 | 2x |
layout_anl_list <- add_expr( |
| 278 | 2x |
layout_anl_list, |
| 279 | 2x |
substitute( |
| 280 | 2x |
expr = rtables::add_overall_col(label = tot_label), |
| 281 | 2x |
env = list(tot_label = total_label) |
| 282 |
) |
|
| 283 |
) |
|
| 284 |
} |
|
| 285 | ||
| 286 | 2x |
layout_anl_list <- add_expr( |
| 287 | 2x |
layout_anl_list, |
| 288 | 2x |
quote( |
| 289 | 2x |
expr = count_patients_with_event( |
| 290 | 2x |
vars = "USUBJID", |
| 291 | 2x |
filters = c("tmp_aefl" = "Y"),
|
| 292 | 2x |
denom = "N_col", |
| 293 | 2x |
.stats = "count_fraction", |
| 294 | 2x |
.labels = c( |
| 295 | 2x |
count_fraction = "Total number of patients with at least one adverse event" |
| 296 |
), |
|
| 297 | 2x |
.indent_mods = c(count_fraction = 0L), |
| 298 | 2x |
table_names = "total_pts_at_least_one" |
| 299 | 2x |
) %>% count_values( |
| 300 | 2x |
"STUDYID", |
| 301 | 2x |
values = study_id, |
| 302 | 2x |
.stats = "count", |
| 303 | 2x |
.labels = c(count = "Total AEs"), |
| 304 | 2x |
table_names = "total_aes" |
| 305 |
) |
|
| 306 |
) |
|
| 307 |
) |
|
| 308 | ||
| 309 | 2x |
table_anl_list <- list() |
| 310 | 2x |
table_anl_list <- add_expr( |
| 311 | 2x |
table_anl_list, |
| 312 | 2x |
substitute( |
| 313 | 2x |
expr = result_anl <- rtables::build_table(lyt = lyt_anl, df = anl, alt_counts_df = df_parent), |
| 314 | 2x |
env = list(df_parent = as.name(parentname)) |
| 315 |
) |
|
| 316 |
) |
|
| 317 | ||
| 318 | 2x |
condition1 <- count_subj && is.character(flag_var_anl) |
| 319 | 2x |
if (condition1) {
|
| 320 | 1x |
layout_anl_list <- add_expr( |
| 321 | 1x |
layout_anl_list, |
| 322 | 1x |
substitute( |
| 323 | 1x |
expr = count_patients_with_flags( |
| 324 | 1x |
var = "USUBJID", |
| 325 | 1x |
flag_variables = flag_var_anl_label, |
| 326 | 1x |
table_names = "count_subj_anl", |
| 327 | 1x |
denom = "N_col", |
| 328 | 1x |
var_labels = "Total number of patients with at least one", |
| 329 | 1x |
show_labels = "visible" |
| 330 |
), |
|
| 331 | 1x |
env = list(flag_var_anl = flag_var_anl) |
| 332 |
) |
|
| 333 |
) |
|
| 334 |
} |
|
| 335 | ||
| 336 | 2x |
condition2 <- count_pt && is.character(flag_var_anl) |
| 337 | 2x |
if (condition2) {
|
| 338 | 1x |
layout_anl_list <- add_expr( |
| 339 | 1x |
layout_anl_list, |
| 340 | 1x |
substitute( |
| 341 | 1x |
expr = count_patients_with_flags( |
| 342 | 1x |
var = llt, |
| 343 | 1x |
flag_variables = flag_var_anl_label, |
| 344 | 1x |
table_names = "count_pt_anl", |
| 345 | 1x |
.stats = "count", |
| 346 | 1x |
.formats = c(count = "xx"), |
| 347 | 1x |
denom = "N_col", |
| 348 | 1x |
var_labels = "Total number of unique preferred terms which are", |
| 349 | 1x |
show_labels = "visible" |
| 350 |
), |
|
| 351 | 1x |
env = list(flag_var_anl = flag_var_anl, llt = llt) |
| 352 |
) |
|
| 353 |
) |
|
| 354 |
} |
|
| 355 | ||
| 356 | 2x |
condition3 <- count_events && is.character(flag_var_anl) |
| 357 | 2x |
if (condition3) {
|
| 358 | 1x |
layout_anl_list <- add_expr( |
| 359 | 1x |
layout_anl_list, |
| 360 | 1x |
substitute( |
| 361 | 1x |
expr = count_patients_with_flags( |
| 362 | 1x |
var = "USUBJID_AESEQ", |
| 363 | 1x |
flag_variables = flag_var_anl_label, |
| 364 | 1x |
table_names = "count_events_anl", |
| 365 | 1x |
.stats = "count", |
| 366 | 1x |
.formats = c(count = "xx"), |
| 367 | 1x |
denom = "N_col", |
| 368 | 1x |
var_labels = "Total number of adverse events which are", |
| 369 | 1x |
show_labels = "visible" |
| 370 |
), |
|
| 371 | 1x |
env = list(flag_var_anl = flag_var_anl) |
| 372 |
) |
|
| 373 |
) |
|
| 374 |
} |
|
| 375 | ||
| 376 | 2x |
condition4 <- count_subj && is.character(flag_var_aesi) |
| 377 | 2x |
if (condition4) {
|
| 378 | 1x |
layout_anl_list <- add_expr( |
| 379 | 1x |
layout_anl_list, |
| 380 | 1x |
substitute( |
| 381 | 1x |
expr = count_patients_with_flags( |
| 382 | 1x |
var = "USUBJID", |
| 383 | 1x |
flag_variables = flag_var_aesi_label, |
| 384 | 1x |
table_names = "count_subj_aesi", |
| 385 | 1x |
denom = "N_col", |
| 386 | 1x |
var_labels = "Medical concepts: number of patients with", |
| 387 | 1x |
show_labels = "visible" |
| 388 |
), |
|
| 389 | 1x |
env = list(flag_var_aesi = flag_var_aesi) |
| 390 |
) |
|
| 391 |
) |
|
| 392 |
} |
|
| 393 | ||
| 394 | 2x |
condition5 <- count_pt && is.character(flag_var_aesi) |
| 395 | 2x |
if (condition5) {
|
| 396 | 1x |
layout_anl_list <- add_expr( |
| 397 | 1x |
layout_anl_list, |
| 398 | 1x |
substitute( |
| 399 | 1x |
expr = count_patients_with_flags( |
| 400 | 1x |
var = llt, |
| 401 | 1x |
flag_variables = flag_var_aesi_label, |
| 402 | 1x |
table_names = "count_pt_aesi", |
| 403 | 1x |
.stats = "count", |
| 404 | 1x |
.formats = c(count = "xx"), |
| 405 | 1x |
denom = "N_col", |
| 406 | 1x |
var_labels = "Medical concepts: number of unique preferred terms which are part of", |
| 407 | 1x |
show_labels = "visible" |
| 408 |
), |
|
| 409 | 1x |
env = list(flag_var_aesi = flag_var_aesi, llt = llt) |
| 410 |
) |
|
| 411 |
) |
|
| 412 |
} |
|
| 413 | ||
| 414 | 2x |
condition6 <- count_events && is.character(flag_var_aesi) |
| 415 | 2x |
if (condition6) {
|
| 416 | 1x |
layout_anl_list <- add_expr( |
| 417 | 1x |
layout_anl_list, |
| 418 | 1x |
substitute( |
| 419 | 1x |
expr = count_patients_with_flags( |
| 420 | 1x |
var = "USUBJID_AESEQ", |
| 421 | 1x |
flag_variables = flag_var_aesi_label, |
| 422 | 1x |
table_names = "count_events_aesi", |
| 423 | 1x |
.stats = "count", |
| 424 | 1x |
.formats = c(count = "xx"), |
| 425 | 1x |
denom = "N_col", |
| 426 | 1x |
var_labels = "Medical concepts: number of adverse events which are part of", |
| 427 | 1x |
show_labels = "visible" |
| 428 |
), |
|
| 429 | 1x |
env = list(flag_var_aesi = flag_var_aesi) |
| 430 |
) |
|
| 431 |
) |
|
| 432 |
} |
|
| 433 | ||
| 434 | 2x |
y$layout_anl <- substitute( |
| 435 | 2x |
expr = lyt_anl <- layout_anl_pipe, |
| 436 | 2x |
env = list( |
| 437 | 2x |
layout_anl_pipe = pipe_expr(layout_anl_list) |
| 438 |
) |
|
| 439 |
) |
|
| 440 | ||
| 441 | 2x |
y$table_anl <- pipe_expr(table_anl_list) |
| 442 | ||
| 443 | 2x |
table_list <- list() |
| 444 | 2x |
table_list <- add_expr( |
| 445 | 2x |
table_list, |
| 446 | 2x |
quote( |
| 447 | 2x |
rtables::col_info(result_parent) <- rtables::col_info(result_anl) |
| 448 |
) |
|
| 449 |
) |
|
| 450 | ||
| 451 | 2x |
all_conditions <- c( |
| 452 | 2x |
condition1, |
| 453 | 2x |
condition2, |
| 454 | 2x |
condition3, |
| 455 | 2x |
condition4, |
| 456 | 2x |
condition5, |
| 457 | 2x |
condition6 |
| 458 |
) |
|
| 459 | ||
| 460 | 2x |
if (any(all_conditions) && (count_dth || count_wd)) {
|
| 461 | ! |
table_list <- add_expr( |
| 462 | ! |
table_list, |
| 463 | ! |
quote( |
| 464 | ! |
expr = result <- rtables::rbind( |
| 465 | ! |
result_anl[1:2, ], |
| 466 | ! |
result_parent, |
| 467 | ! |
result_anl[3:nrow(result_anl), ] |
| 468 |
) |
|
| 469 |
) |
|
| 470 |
) |
|
| 471 | 2x |
} else if (any(all_conditions)) {
|
| 472 | 1x |
table_list <- add_expr( |
| 473 | 1x |
table_list, |
| 474 | 1x |
quote( |
| 475 | 1x |
expr = result <- rtables::rbind( |
| 476 | 1x |
result_anl[1:2, ], |
| 477 | 1x |
result_anl[3:nrow(result_anl), ] |
| 478 |
) |
|
| 479 |
) |
|
| 480 |
) |
|
| 481 |
} else {
|
|
| 482 | 1x |
table_list <- add_expr( |
| 483 | 1x |
table_list, |
| 484 | 1x |
quote( |
| 485 | 1x |
result <- rtables::rbind(result_anl, result_parent) |
| 486 |
) |
|
| 487 |
) |
|
| 488 |
} |
|
| 489 | ||
| 490 | 2x |
y$table <- bracket_expr(table_list) |
| 491 | ||
| 492 | 2x |
y |
| 493 |
} |
|
| 494 | ||
| 495 |
#' teal Module: Adverse Events Summary |
|
| 496 |
#' |
|
| 497 |
#' This module produces an adverse events summary table. |
|
| 498 |
#' |
|
| 499 |
#' @inheritParams module_arguments |
|
| 500 |
#' @inheritParams template_arguments |
|
| 501 |
#' @inheritParams template_events_summary |
|
| 502 |
#' @param arm_var ([teal.transform::choices_selected()])\cr object with all |
|
| 503 |
#' available choices and preselected option for variable names that can be used as `arm_var`. |
|
| 504 |
#' It defines the grouping variable(s) in the results table. |
|
| 505 |
#' If there are two elements selected for `arm_var`, |
|
| 506 |
#' second variable will be nested under the first variable. |
|
| 507 |
#' @param dthfl_var ([teal.transform::choices_selected()])\cr object |
|
| 508 |
#' with all available choices and preselected option for variable names that can be used as death flag variable. |
|
| 509 |
#' Records with `"Y"`` are summarized in the table row for "Total number of deaths". |
|
| 510 |
#' @param dcsreas_var ([teal.transform::choices_selected()])\cr object |
|
| 511 |
#' with all available choices and preselected option for variable names that can be used as study discontinuation |
|
| 512 |
#' reason variable. Records with `"ADVERSE EVENTS"` are summarized in the table row for |
|
| 513 |
#' "Total number of patients withdrawn from study due to an AE". |
|
| 514 |
#' @param flag_var_anl ([teal.transform::choices_selected()] or `NULL`)\cr |
|
| 515 |
#' vector with names of flag variables from `dataset` used to count adverse event sub-groups (e.g. Serious events, |
|
| 516 |
#' Related events, etc.). Variable labels are used as table row names if they exist. |
|
| 517 |
#' @param flag_var_aesi ([teal.transform::choices_selected()] or `NULL`)\cr |
|
| 518 |
#' vector with names of flag variables from `dataset` used to count adverse event special interest groups. All flag |
|
| 519 |
#' variables must be of type `logical`. Variable labels are used as table row names if they exist. |
|
| 520 |
#' @param aeseq_var ([teal.transform::choices_selected()])\cr variable for |
|
| 521 |
#' adverse events sequence number from `dataset`. Used for counting total number of events. |
|
| 522 |
#' |
|
| 523 |
#' @inherit module_arguments return seealso |
|
| 524 |
#' |
|
| 525 |
#' @examples |
|
| 526 |
#' library(dplyr) |
|
| 527 |
#' |
|
| 528 |
#' data <- teal_data() |
|
| 529 |
#' data <- within(data, {
|
|
| 530 |
#' ADSL <- tmc_ex_adsl %>% |
|
| 531 |
#' mutate( |
|
| 532 |
#' DTHFL = case_when( |
|
| 533 |
#' !is.na(DTHDT) ~ "Y", |
|
| 534 |
#' TRUE ~ "" |
|
| 535 |
#' ) %>% with_label("Subject Death Flag")
|
|
| 536 |
#' ) |
|
| 537 |
#' ADAE <- tmc_ex_adae |
|
| 538 |
#' |
|
| 539 |
#' add_event_flags <- function(dat) {
|
|
| 540 |
#' dat <- dat %>% |
|
| 541 |
#' mutate( |
|
| 542 |
#' TMPFL_SER = AESER == "Y", |
|
| 543 |
#' TMPFL_REL = AEREL == "Y", |
|
| 544 |
#' TMPFL_GR5 = AETOXGR == "5", |
|
| 545 |
#' TMP_SMQ01 = !is.na(SMQ01NAM), |
|
| 546 |
#' TMP_SMQ02 = !is.na(SMQ02NAM), |
|
| 547 |
#' TMP_CQ01 = !is.na(CQ01NAM) |
|
| 548 |
#' ) |
|
| 549 |
#' column_labels <- list( |
|
| 550 |
#' TMPFL_SER = "Serious AE", |
|
| 551 |
#' TMPFL_REL = "Related AE", |
|
| 552 |
#' TMPFL_GR5 = "Grade 5 AE", |
|
| 553 |
#' TMP_SMQ01 = aesi_label(dat[["SMQ01NAM"]], dat[["SMQ01SC"]]), |
|
| 554 |
#' TMP_SMQ02 = aesi_label("Y.9.9.9.9/Z.9.9.9.9 AESI"),
|
|
| 555 |
#' TMP_CQ01 = aesi_label(dat[["CQ01NAM"]]) |
|
| 556 |
#' ) |
|
| 557 |
#' col_labels(dat)[names(column_labels)] <- as.character(column_labels) |
|
| 558 |
#' dat |
|
| 559 |
#' } |
|
| 560 |
#' |
|
| 561 |
#' #' Generating user-defined event flags. |
|
| 562 |
#' ADAE <- ADAE %>% add_event_flags() |
|
| 563 |
#' |
|
| 564 |
#' ae_anl_vars <- names(ADAE)[startsWith(names(ADAE), "TMPFL_")] |
|
| 565 |
#' aesi_vars <- names(ADAE)[startsWith(names(ADAE), "TMP_")] |
|
| 566 |
#' }) |
|
| 567 |
#' |
|
| 568 |
#' datanames <- c("ADSL", "ADAE")
|
|
| 569 |
#' datanames(data) <- datanames |
|
| 570 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 571 |
#' |
|
| 572 |
#' app <- init( |
|
| 573 |
#' data = data, |
|
| 574 |
#' modules = modules( |
|
| 575 |
#' tm_t_events_summary( |
|
| 576 |
#' label = "Adverse Events Summary", |
|
| 577 |
#' dataname = "ADAE", |
|
| 578 |
#' arm_var = choices_selected( |
|
| 579 |
#' choices = variable_choices("ADSL", c("ARM", "ARMCD")),
|
|
| 580 |
#' selected = "ARM" |
|
| 581 |
#' ), |
|
| 582 |
#' flag_var_anl = choices_selected( |
|
| 583 |
#' choices = variable_choices("ADAE", data[["ae_anl_vars"]]),
|
|
| 584 |
#' selected = data[["ae_anl_vars"]][1], |
|
| 585 |
#' keep_order = TRUE, |
|
| 586 |
#' fixed = FALSE |
|
| 587 |
#' ), |
|
| 588 |
#' flag_var_aesi = choices_selected( |
|
| 589 |
#' choices = variable_choices("ADAE", data[["aesi_vars"]]),
|
|
| 590 |
#' selected = data[["aesi_vars"]][1], |
|
| 591 |
#' keep_order = TRUE, |
|
| 592 |
#' fixed = FALSE |
|
| 593 |
#' ), |
|
| 594 |
#' add_total = TRUE |
|
| 595 |
#' ) |
|
| 596 |
#' ) |
|
| 597 |
#' ) |
|
| 598 |
#' if (interactive()) {
|
|
| 599 |
#' shinyApp(app$ui, app$server) |
|
| 600 |
#' } |
|
| 601 |
#' |
|
| 602 |
#' @export |
|
| 603 |
tm_t_events_summary <- function(label, |
|
| 604 |
dataname, |
|
| 605 |
parentname = ifelse( |
|
| 606 |
inherits(arm_var, "data_extract_spec"), |
|
| 607 |
teal.transform::datanames_input(arm_var), |
|
| 608 |
"ADSL" |
|
| 609 |
), |
|
| 610 |
arm_var, |
|
| 611 |
flag_var_anl = NULL, |
|
| 612 |
flag_var_aesi = NULL, |
|
| 613 |
dthfl_var = teal.transform::choices_selected( |
|
| 614 |
teal.transform::variable_choices(parentname, "DTHFL"), "DTHFL", |
|
| 615 |
fixed = TRUE |
|
| 616 |
), |
|
| 617 |
dcsreas_var = teal.transform::choices_selected( |
|
| 618 |
teal.transform::variable_choices(parentname, "DCSREAS"), "DCSREAS", |
|
| 619 |
fixed = TRUE |
|
| 620 |
), |
|
| 621 |
llt = teal.transform::choices_selected( |
|
| 622 |
teal.transform::variable_choices(dataname, "AEDECOD"), "AEDECOD", |
|
| 623 |
fixed = TRUE |
|
| 624 |
), |
|
| 625 |
aeseq_var = teal.transform::choices_selected( |
|
| 626 |
teal.transform::variable_choices(dataname, "AESEQ"), "AESEQ", |
|
| 627 |
fixed = TRUE |
|
| 628 |
), |
|
| 629 |
add_total = TRUE, |
|
| 630 |
total_label = default_total_label(), |
|
| 631 |
na_level = default_na_str(), |
|
| 632 |
count_dth = TRUE, |
|
| 633 |
count_wd = TRUE, |
|
| 634 |
count_subj = TRUE, |
|
| 635 |
count_pt = TRUE, |
|
| 636 |
count_events = TRUE, |
|
| 637 |
pre_output = NULL, |
|
| 638 |
post_output = NULL, |
|
| 639 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 640 | ! |
message("Initializing tm_t_events_summary")
|
| 641 | ! |
checkmate::assert_string(label) |
| 642 | ! |
checkmate::assert_string(dataname) |
| 643 | ! |
checkmate::assert_string(parentname) |
| 644 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 645 | ! |
checkmate::assert_class(flag_var_anl, "choices_selected", null.ok = TRUE) |
| 646 | ! |
checkmate::assert_class(flag_var_aesi, "choices_selected", null.ok = TRUE) |
| 647 | ! |
checkmate::assert_class(dthfl_var, "choices_selected") |
| 648 | ! |
checkmate::assert_class(dcsreas_var, "choices_selected") |
| 649 | ! |
checkmate::assert_class(llt, "choices_selected") |
| 650 | ! |
checkmate::assert_class(aeseq_var, "choices_selected") |
| 651 | ! |
checkmate::assert_flag(add_total) |
| 652 | ! |
checkmate::assert_string(total_label) |
| 653 | ! |
checkmate::assert_string(na_level) |
| 654 | ! |
checkmate::assert_flag(count_dth) |
| 655 | ! |
checkmate::assert_flag(count_wd) |
| 656 | ! |
checkmate::assert_flag(count_subj) |
| 657 | ! |
checkmate::assert_flag(count_pt) |
| 658 | ! |
checkmate::assert_flag(count_events) |
| 659 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 660 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 661 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 662 | ||
| 663 | ! |
args <- c(as.list(environment())) |
| 664 | ||
| 665 | ! |
data_extract_list <- list( |
| 666 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 667 | ! |
dthfl_var = cs_to_des_select(dthfl_var, dataname = parentname), |
| 668 | ! |
dcsreas_var = cs_to_des_select(dcsreas_var, dataname = parentname), |
| 669 | ! |
flag_var_anl = `if`( |
| 670 | ! |
is.null(flag_var_anl), |
| 671 | ! |
NULL, |
| 672 | ! |
cs_to_des_select(flag_var_anl, dataname = dataname, multiple = TRUE, ordered = TRUE) |
| 673 |
), |
|
| 674 | ! |
flag_var_aesi = `if`( |
| 675 | ! |
is.null(flag_var_aesi), |
| 676 | ! |
NULL, |
| 677 | ! |
cs_to_des_select(flag_var_aesi, dataname = dataname, multiple = TRUE, ordered = TRUE) |
| 678 |
), |
|
| 679 | ! |
aeseq_var = cs_to_des_select(aeseq_var, dataname = dataname), |
| 680 | ! |
llt = cs_to_des_select(llt, dataname = dataname) |
| 681 |
) |
|
| 682 | ||
| 683 | ! |
module( |
| 684 | ! |
label = label, |
| 685 | ! |
ui = ui_t_events_summary, |
| 686 | ! |
ui_args = c(data_extract_list, args), |
| 687 | ! |
server = srv_t_events_summary, |
| 688 | ! |
server_args = c( |
| 689 | ! |
data_extract_list, |
| 690 | ! |
list( |
| 691 | ! |
dataname = dataname, |
| 692 | ! |
parentname = parentname, |
| 693 | ! |
label = label, |
| 694 | ! |
total_label = total_label, |
| 695 | ! |
na_level = na_level, |
| 696 | ! |
basic_table_args = basic_table_args |
| 697 |
) |
|
| 698 |
), |
|
| 699 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 700 |
) |
|
| 701 |
} |
|
| 702 | ||
| 703 |
#' @keywords internal |
|
| 704 |
ui_t_events_summary <- function(id, ...) {
|
|
| 705 | ! |
ns <- NS(id) |
| 706 | ! |
a <- list(...) |
| 707 | ||
| 708 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 709 | ! |
a$arm_var, |
| 710 | ! |
a$dthfl_var, |
| 711 | ! |
a$dcsreas_var, |
| 712 | ! |
a$flag_var_anl, |
| 713 | ! |
a$flag_var_aesi, |
| 714 | ! |
a$aeseq_var, |
| 715 | ! |
a$llt |
| 716 |
) |
|
| 717 | ||
| 718 | ! |
teal.widgets::standard_layout( |
| 719 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 720 | ! |
encoding = tags$div( |
| 721 |
### Reporter |
|
| 722 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 723 |
### |
|
| 724 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 725 | ! |
teal.transform::datanames_input( |
| 726 | ! |
a[c("arm_var", "dthfl_var", "dcsreas_var", "flag_var_anl", "flag_var_aesi", "aeseq_var", "llt")]
|
| 727 |
), |
|
| 728 | ! |
teal.transform::data_extract_ui( |
| 729 | ! |
id = ns("arm_var"),
|
| 730 | ! |
label = "Select Treatment Variable", |
| 731 | ! |
data_extract_spec = a$arm_var, |
| 732 | ! |
is_single_dataset = is_single_dataset_value |
| 733 |
), |
|
| 734 | ! |
`if`( |
| 735 | ! |
is.null(a$flag_var_anl), |
| 736 | ! |
NULL, |
| 737 | ! |
teal.transform::data_extract_ui( |
| 738 | ! |
id = ns("flag_var_anl"),
|
| 739 | ! |
label = "Event Flag Variables", |
| 740 | ! |
data_extract_spec = a$flag_var_anl, |
| 741 | ! |
is_single_dataset = is_single_dataset_value |
| 742 |
) |
|
| 743 |
), |
|
| 744 | ! |
`if`( |
| 745 | ! |
is.null(a$flag_var_aesi), |
| 746 | ! |
NULL, |
| 747 | ! |
teal.transform::data_extract_ui( |
| 748 | ! |
id = ns("flag_var_aesi"),
|
| 749 | ! |
label = "AE Basket Flag Variables", |
| 750 | ! |
data_extract_spec = a$flag_var_aesi, |
| 751 | ! |
is_single_dataset = is_single_dataset_value |
| 752 |
) |
|
| 753 |
), |
|
| 754 | ! |
checkboxInput( |
| 755 | ! |
ns("add_total"),
|
| 756 | ! |
"Add All Patients column", |
| 757 | ! |
value = a$add_total |
| 758 |
), |
|
| 759 | ! |
teal.widgets::panel_item( |
| 760 | ! |
"Table Settings", |
| 761 | ! |
checkboxInput( |
| 762 | ! |
ns("count_dth"),
|
| 763 | ! |
"Count deaths", |
| 764 | ! |
value = a$count_dth |
| 765 |
), |
|
| 766 | ! |
checkboxInput( |
| 767 | ! |
ns("count_wd"),
|
| 768 | ! |
"Count withdrawals due to AE", |
| 769 | ! |
value = a$count_wd |
| 770 |
), |
|
| 771 | ! |
checkboxInput( |
| 772 | ! |
ns("count_subj"),
|
| 773 | ! |
"Count patients", |
| 774 | ! |
value = a$count_subj |
| 775 |
), |
|
| 776 | ! |
checkboxInput( |
| 777 | ! |
ns("count_pt"),
|
| 778 | ! |
"Count preferred terms", |
| 779 | ! |
value = a$count_pt |
| 780 |
), |
|
| 781 | ! |
checkboxInput( |
| 782 | ! |
ns("count_events"),
|
| 783 | ! |
"Count events", |
| 784 | ! |
value = a$count_events |
| 785 |
) |
|
| 786 |
), |
|
| 787 | ! |
teal.widgets::panel_group( |
| 788 | ! |
teal.widgets::panel_item( |
| 789 | ! |
"Additional Variables Info", |
| 790 | ! |
teal.transform::data_extract_ui( |
| 791 | ! |
id = ns("dthfl_var"),
|
| 792 | ! |
label = "Death Flag Variable", |
| 793 | ! |
data_extract_spec = a$dthfl_var, |
| 794 | ! |
is_single_dataset = is_single_dataset_value |
| 795 |
), |
|
| 796 | ! |
teal.transform::data_extract_ui( |
| 797 | ! |
id = ns("dcsreas_var"),
|
| 798 | ! |
label = "Study Discontinuation Reason Variable", |
| 799 | ! |
data_extract_spec = a$dcsreas_var, |
| 800 | ! |
is_single_dataset = is_single_dataset_value |
| 801 |
), |
|
| 802 | ! |
teal.transform::data_extract_ui( |
| 803 | ! |
id = ns("aeseq_var"),
|
| 804 | ! |
label = "AE Sequence Variable", |
| 805 | ! |
data_extract_spec = a$aeseq_var, |
| 806 | ! |
is_single_dataset = is_single_dataset_value |
| 807 |
), |
|
| 808 | ! |
teal.transform::data_extract_ui( |
| 809 | ! |
id = ns("llt"),
|
| 810 | ! |
label = "AE Term Variable", |
| 811 | ! |
data_extract_spec = a$llt, |
| 812 | ! |
is_single_dataset = is_single_dataset_value |
| 813 |
) |
|
| 814 |
) |
|
| 815 |
) |
|
| 816 |
), |
|
| 817 | ! |
forms = tagList( |
| 818 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 819 |
), |
|
| 820 | ! |
pre_output = a$pre_output, |
| 821 | ! |
post_output = a$post_output |
| 822 |
) |
|
| 823 |
} |
|
| 824 | ||
| 825 |
#' @keywords internal |
|
| 826 |
srv_t_events_summary <- function(id, |
|
| 827 |
data, |
|
| 828 |
reporter, |
|
| 829 |
filter_panel_api, |
|
| 830 |
dataname, |
|
| 831 |
parentname, |
|
| 832 |
arm_var, |
|
| 833 |
dthfl_var, |
|
| 834 |
dcsreas_var, |
|
| 835 |
flag_var_anl, |
|
| 836 |
flag_var_aesi, |
|
| 837 |
aeseq_var, |
|
| 838 |
llt, |
|
| 839 |
label, |
|
| 840 |
total_label, |
|
| 841 |
na_level, |
|
| 842 |
basic_table_args) {
|
|
| 843 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 844 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 845 | ! |
checkmate::assert_class(data, "reactive") |
| 846 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 847 | ||
| 848 | ! |
moduleServer(id, function(input, output, session) {
|
| 849 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 850 | ! |
data_extract_vars <- list( |
| 851 | ! |
arm_var = arm_var, dthfl_var = dthfl_var, dcsreas_var = dcsreas_var, |
| 852 | ! |
aeseq_var = aeseq_var, llt = llt |
| 853 |
) |
|
| 854 | ||
| 855 | ! |
if (!is.null(flag_var_anl)) {
|
| 856 | ! |
data_extract_vars[["flag_var_anl"]] <- flag_var_anl |
| 857 |
} |
|
| 858 | ||
| 859 | ! |
if (!is.null(flag_var_aesi)) {
|
| 860 | ! |
data_extract_vars[["flag_var_aesi"]] <- flag_var_aesi |
| 861 |
} |
|
| 862 | ||
| 863 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 864 | ! |
data_extract = data_extract_vars, |
| 865 | ! |
datasets = data, |
| 866 | ! |
select_validation_rule = list( |
| 867 | ! |
arm_var = ~ if (length(.) != 1 && length(.) != 2) "Please select exactly 1 or 2 treatment variables", |
| 868 | ! |
dthfl_var = shinyvalidate::sv_required("Death Flag Variable is requried"),
|
| 869 | ! |
dcsreas_var = shinyvalidate::sv_required("Study Discontinuation Reason Variable is required"),
|
| 870 | ! |
aeseq_var = shinyvalidate::sv_required("AE Sequence Variable is required"),
|
| 871 | ! |
llt = shinyvalidate::sv_required("AE Term Variable is required")
|
| 872 |
) |
|
| 873 |
) |
|
| 874 | ||
| 875 | ! |
iv_r <- reactive({
|
| 876 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 877 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 878 |
}) |
|
| 879 | ||
| 880 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 881 | ! |
datasets = data, |
| 882 | ! |
selector_list = selector_list, |
| 883 | ! |
merge_function = "dplyr::inner_join" |
| 884 |
) |
|
| 885 | ||
| 886 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 887 | ! |
datasets = data, |
| 888 | ! |
data_extract = Filter(Negate(is.null), list(arm_var = arm_var, dthfl_var = dthfl_var, dcsreas_var = dcsreas_var)), |
| 889 | ! |
anl_name = "ANL_ADSL" |
| 890 |
) |
|
| 891 | ||
| 892 | ! |
anl_q <- reactive({
|
| 893 | ! |
data() %>% |
| 894 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 895 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 896 |
}) |
|
| 897 | ||
| 898 | ! |
merged <- list( |
| 899 | ! |
anl_input_r = anl_inputs, |
| 900 | ! |
adsl_input_r = adsl_inputs, |
| 901 | ! |
anl_q = anl_q |
| 902 |
) |
|
| 903 | ||
| 904 | ! |
validate_checks <- reactive({
|
| 905 | ! |
teal::validate_inputs(iv_r()) |
| 906 | ||
| 907 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 908 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 909 | ||
| 910 | ! |
input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) |
| 911 | ! |
input_dthfl_var <- as.vector(merged$anl_input_r()$columns_source$dthfl_var) |
| 912 | ! |
input_dcsreas_var <- as.vector(merged$anl_input_r()$columns_source$dcsreas_var) |
| 913 | ! |
input_flag_var_anl <- if (!is.null(flag_var_anl)) {
|
| 914 | ! |
as.vector(merged$anl_input_r()$columns_source$flag_var_anl) |
| 915 |
} else {
|
|
| 916 | ! |
NULL |
| 917 |
} |
|
| 918 | ! |
input_flag_var_aesi <- if (!is.null(flag_var_anl)) {
|
| 919 | ! |
as.vector(merged$anl_input_r()$columns_source$flag_var_aesi) |
| 920 |
} else {
|
|
| 921 | ! |
NULL |
| 922 |
} |
|
| 923 | ! |
input_aeseq_var <- as.vector(merged$anl_input_r()$columns_source$aeseq_var) |
| 924 | ! |
input_llt <- as.vector(merged$anl_input_r()$columns_source$llt) |
| 925 | ||
| 926 | ! |
validate( |
| 927 | ! |
need(is.factor(adsl_filtered[[input_arm_var[[1]]]]), "Treatment variable is not a factor."), |
| 928 | ! |
if (length(input_arm_var) == 2) {
|
| 929 | ! |
need( |
| 930 | ! |
is.factor(adsl_filtered[[input_arm_var[[2]]]]) && all(!adsl_filtered[[input_arm_var[[2]]]] %in% c( |
| 931 | ! |
"", NA |
| 932 |
)), |
|
| 933 | ! |
"Please check nested treatment variable which needs to be a factor without NA or empty strings." |
| 934 |
) |
|
| 935 |
} |
|
| 936 |
) |
|
| 937 | ||
| 938 |
# validate inputs |
|
| 939 | ! |
validate_standard_inputs( |
| 940 | ! |
adsl = adsl_filtered, |
| 941 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var, input_dthfl_var, input_dcsreas_var),
|
| 942 | ! |
anl = anl_filtered, |
| 943 | ! |
anlvars = c("USUBJID", "STUDYID", input_flag_var_anl, input_flag_var_aesi, input_aeseq_var, input_llt),
|
| 944 | ! |
arm_var = input_arm_var[[1]] |
| 945 |
) |
|
| 946 |
}) |
|
| 947 | ||
| 948 |
# The R-code corresponding to the analysis. |
|
| 949 | ! |
table_q <- reactive({
|
| 950 | ! |
validate_checks() |
| 951 | ||
| 952 | ! |
input_flag_var_anl <- if (!is.null(flag_var_anl)) {
|
| 953 | ! |
as.vector(merged$anl_input_r()$columns_source$flag_var_anl) |
| 954 |
} else {
|
|
| 955 | ! |
NULL |
| 956 |
} |
|
| 957 | ! |
input_flag_var_aesi <- if (!is.null(flag_var_anl)) {
|
| 958 | ! |
as.vector(merged$anl_input_r()$columns_source$flag_var_aesi) |
| 959 |
} else {
|
|
| 960 | ! |
NULL |
| 961 |
} |
|
| 962 | ||
| 963 | ! |
my_calls <- template_events_summary( |
| 964 | ! |
anl_name = "ANL", |
| 965 | ! |
parentname = "ANL_ADSL", |
| 966 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 967 | ! |
dthfl_var = as.vector(merged$anl_input_r()$columns_source$dthfl_var), |
| 968 | ! |
dcsreas_var = as.vector(merged$anl_input_r()$columns_source$dcsreas_var), |
| 969 | ! |
flag_var_anl = if (length(input_flag_var_anl) != 0) input_flag_var_anl else NULL, |
| 970 | ! |
flag_var_aesi = if (length(input_flag_var_aesi) != 0) input_flag_var_aesi else NULL, |
| 971 | ! |
aeseq_var = as.vector(merged$anl_input_r()$columns_source$aeseq_var), |
| 972 | ! |
llt = as.vector(merged$anl_input_r()$columns_source$llt), |
| 973 | ! |
add_total = input$add_total, |
| 974 | ! |
total_label = total_label, |
| 975 | ! |
na_level = na_level, |
| 976 | ! |
count_dth = input$count_dth, |
| 977 | ! |
count_wd = input$count_wd, |
| 978 | ! |
count_subj = input$count_subj, |
| 979 | ! |
count_pt = input$count_pt, |
| 980 | ! |
count_events = input$count_events |
| 981 |
) |
|
| 982 | ||
| 983 | ! |
all_basic_table_args <- teal.widgets::resolve_basic_table_args(user_table = basic_table_args) |
| 984 | ! |
teal.code::eval_code( |
| 985 | ! |
merged$anl_q(), |
| 986 | ! |
as.expression(my_calls) |
| 987 |
) %>% |
|
| 988 | ! |
teal.code::eval_code( |
| 989 | ! |
substitute( |
| 990 | ! |
expr = {
|
| 991 | ! |
rtables::main_title(result) <- title |
| 992 | ! |
rtables::main_footer(result) <- footer |
| 993 | ! |
rtables::prov_footer(result) <- p_footer |
| 994 | ! |
rtables::subtitles(result) <- subtitle |
| 995 | ! |
result |
| 996 | ! |
}, env = list( |
| 997 | ! |
title = `if`(is.null(all_basic_table_args$title), label, all_basic_table_args$title), |
| 998 | ! |
footer = `if`(is.null(all_basic_table_args$main_footer), "", all_basic_table_args$main_footer), |
| 999 | ! |
p_footer = `if`(is.null(all_basic_table_args$prov_footer), "", all_basic_table_args$prov_footer), |
| 1000 | ! |
subtitle = `if`(is.null(all_basic_table_args$subtitles), "", all_basic_table_args$subtitles) |
| 1001 |
) |
|
| 1002 |
) |
|
| 1003 |
) |
|
| 1004 |
}) |
|
| 1005 | ||
| 1006 |
# Outputs to render. |
|
| 1007 | ! |
table_r <- reactive(table_q()[["result"]]) |
| 1008 | ||
| 1009 | ! |
teal.widgets::table_with_settings_srv( |
| 1010 | ! |
id = "table", |
| 1011 | ! |
table_r = table_r |
| 1012 |
) |
|
| 1013 | ||
| 1014 | ! |
teal.widgets::verbatim_popup_srv( |
| 1015 | ! |
id = "rcode", |
| 1016 | ! |
verbatim_content = reactive(teal.code::get_code(table_q())), |
| 1017 | ! |
title = label |
| 1018 |
) |
|
| 1019 | ||
| 1020 |
### REPORTER |
|
| 1021 | ! |
if (with_reporter) {
|
| 1022 | ! |
card_fun <- function(comment, label) {
|
| 1023 | ! |
card <- teal::report_card_template( |
| 1024 | ! |
title = "Adverse Events Summary Table", |
| 1025 | ! |
label = label, |
| 1026 | ! |
with_filter = with_filter, |
| 1027 | ! |
filter_panel_api = filter_panel_api |
| 1028 |
) |
|
| 1029 | ! |
card$append_text("Table", "header3")
|
| 1030 | ! |
card$append_table(table_r()) |
| 1031 | ! |
if (!comment == "") {
|
| 1032 | ! |
card$append_text("Comment", "header3")
|
| 1033 | ! |
card$append_text(comment) |
| 1034 |
} |
|
| 1035 | ! |
card$append_src(teal.code::get_code(table_q())) |
| 1036 | ! |
card |
| 1037 |
} |
|
| 1038 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 1039 |
} |
|
| 1040 |
### |
|
| 1041 |
}) |
|
| 1042 |
} |
| 1 |
#' Template: Grade Summary Table |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a grade summary table. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param anl_toxgrade_var (`character`)\cr name of the variable indicating the analysis toxicity grade. |
|
| 7 |
#' @param base_toxgrade_var (`character`)\cr name of the variable indicating the baseline toxicity grade. |
|
| 8 |
#' @param code_missing_baseline (`logical`)\cr whether missing baseline grades should be counted as grade 0. |
|
| 9 |
#' |
|
| 10 |
#' @inherit template_arguments return |
|
| 11 |
#' |
|
| 12 |
#' @seealso [tm_t_shift_by_grade()] |
|
| 13 |
#' |
|
| 14 |
#' @keywords internal |
|
| 15 |
template_shift_by_grade <- function(parentname, |
|
| 16 |
dataname, |
|
| 17 |
arm_var = "ARM", |
|
| 18 |
id_var = "USUBJID", |
|
| 19 |
visit_var = "AVISIT", |
|
| 20 |
worst_flag_var = c("WGRLOVFL", "WGRLOFL", "WGRHIVFL", "WGRHIFL"),
|
|
| 21 |
worst_flag_indicator = "Y", |
|
| 22 |
anl_toxgrade_var = "ATOXGR", |
|
| 23 |
base_toxgrade_var = "BTOXGR", |
|
| 24 |
paramcd = "PARAMCD", |
|
| 25 |
drop_arm_levels = TRUE, |
|
| 26 |
add_total = FALSE, |
|
| 27 |
total_label = default_total_label(), |
|
| 28 |
na_level = default_na_str(), |
|
| 29 |
code_missing_baseline = FALSE, |
|
| 30 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 31 | 4x |
checkmate::assert_string(dataname) |
| 32 | 4x |
checkmate::assert_string(parentname) |
| 33 | 4x |
checkmate::assert_string(arm_var) |
| 34 | 4x |
checkmate::assert_string(id_var) |
| 35 | 4x |
checkmate::assert_string(visit_var) |
| 36 | 4x |
checkmate::assert_string(worst_flag_indicator) |
| 37 | 4x |
checkmate::assert_character(worst_flag_var) |
| 38 | 4x |
checkmate::assert_string(anl_toxgrade_var) |
| 39 | 4x |
checkmate::assert_string(base_toxgrade_var) |
| 40 | 4x |
checkmate::assert_string(paramcd) |
| 41 | 4x |
checkmate::assert_flag(drop_arm_levels) |
| 42 | 4x |
checkmate::assert_flag(add_total) |
| 43 | 4x |
checkmate::assert_string(total_label) |
| 44 | 4x |
checkmate::assert_string(na_level) |
| 45 | ||
| 46 | 4x |
worst_flag_var <- match.arg(worst_flag_var) |
| 47 | ||
| 48 | 3x |
y <- list() |
| 49 | 3x |
data_list <- list() |
| 50 | ||
| 51 | 3x |
data_list <- add_expr( |
| 52 | 3x |
data_list, |
| 53 | 3x |
substitute( |
| 54 | 3x |
expr = anl <- df %>% |
| 55 | 3x |
dplyr::filter(worst_flag_var == worst_flag_indicator), |
| 56 | 3x |
env = list( |
| 57 | 3x |
df = as.name(dataname), |
| 58 | 3x |
worst_flag_var = as.name(worst_flag_var), |
| 59 | 3x |
worst_flag_indicator = worst_flag_indicator |
| 60 |
) |
|
| 61 |
) |
|
| 62 |
) |
|
| 63 | ||
| 64 | 3x |
data_list <- add_expr( |
| 65 | 3x |
data_list, |
| 66 | 3x |
prepare_arm_levels( |
| 67 | 3x |
dataname = "anl", |
| 68 | 3x |
parentname = parentname, |
| 69 | 3x |
arm_var = arm_var, |
| 70 | 3x |
drop_arm_levels = drop_arm_levels |
| 71 |
) |
|
| 72 |
) |
|
| 73 | ||
| 74 | 3x |
data_list <- add_expr( |
| 75 | 3x |
data_list, |
| 76 | 3x |
substitute( |
| 77 | 3x |
expr = dataname <- df_explicit_na(dataname, na_level = na_str), |
| 78 | 3x |
env = list( |
| 79 | 3x |
dataname = as.name("anl"),
|
| 80 | 3x |
na_str = na_level |
| 81 |
) |
|
| 82 |
) |
|
| 83 |
) |
|
| 84 | ||
| 85 | 3x |
data_list <- add_expr( |
| 86 | 3x |
data_list, |
| 87 | 3x |
substitute( |
| 88 | 3x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 89 | 3x |
env = list( |
| 90 | 3x |
parentname = as.name(parentname), |
| 91 | 3x |
na_str = na_level |
| 92 |
) |
|
| 93 |
) |
|
| 94 |
) |
|
| 95 | ||
| 96 | 3x |
by_visit_fl <- dplyr::if_else(worst_flag_var %in% c("WGRLOVFL", "WGRHIVFL"), TRUE, FALSE)
|
| 97 | ||
| 98 | 3x |
data_list <- add_expr( |
| 99 | 3x |
data_list, |
| 100 | 3x |
substitute( |
| 101 | 3x |
by_visit <- by_visit_fl, |
| 102 | 3x |
env = list( |
| 103 | 3x |
by_visit_fl = by_visit_fl |
| 104 |
) |
|
| 105 |
) |
|
| 106 |
) |
|
| 107 | ||
| 108 |
# Create new grouping variables ATOXGR_GP, BTOXGR_GP |
|
| 109 | 3x |
if (!code_missing_baseline) {
|
| 110 | 3x |
if (worst_flag_var %in% c("WGRLOVFL", "WGRLOFL")) {
|
| 111 | 3x |
data_list <- add_expr( |
| 112 | 3x |
data_list, |
| 113 | 3x |
substitute( |
| 114 | 3x |
dataname <- dplyr::mutate(dataname, |
| 115 | 3x |
ATOXGR_GP = factor(dplyr::case_when( |
| 116 | 3x |
ATOXGR %in% c(0, 1, 2, 3, 4) ~ "Not Low", |
| 117 | 3x |
ATOXGR == -1 ~ "1", |
| 118 | 3x |
ATOXGR == -2 ~ "2", |
| 119 | 3x |
ATOXGR == -3 ~ "3", |
| 120 | 3x |
ATOXGR == -4 ~ "4", |
| 121 | 3x |
ATOXGR == na_level ~ "Missing" |
| 122 |
)), |
|
| 123 | 3x |
BTOXGR_GP = factor(dplyr::case_when( |
| 124 | 3x |
BTOXGR %in% c(0, 1, 2, 3, 4) ~ "Not Low", |
| 125 | 3x |
BTOXGR == -1 ~ "1", |
| 126 | 3x |
BTOXGR == -2 ~ "2", |
| 127 | 3x |
BTOXGR == -3 ~ "3", |
| 128 | 3x |
BTOXGR == -4 ~ "4", |
| 129 | 3x |
BTOXGR == na_level ~ "Missing" |
| 130 |
)) |
|
| 131 |
), |
|
| 132 | 3x |
env = list( |
| 133 | 3x |
dataname = as.name("anl"),
|
| 134 | 3x |
ATOXGR = as.name(anl_toxgrade_var), |
| 135 | 3x |
BTOXGR = as.name(base_toxgrade_var), |
| 136 | 3x |
na_level = na_level |
| 137 |
) |
|
| 138 |
) |
|
| 139 |
) |
|
| 140 |
} else {
|
|
| 141 | ! |
data_list <- add_expr( |
| 142 | ! |
data_list, |
| 143 | ! |
substitute( |
| 144 | ! |
dataname <- dplyr::mutate(dataname, |
| 145 | ! |
ATOXGR_GP = factor(dplyr::case_when( |
| 146 | ! |
ATOXGR %in% c(0, -1, -2, -3, -4) ~ "Not High", |
| 147 | ! |
ATOXGR == 1 ~ "1", |
| 148 | ! |
ATOXGR == 2 ~ "2", |
| 149 | ! |
ATOXGR == 3 ~ "3", |
| 150 | ! |
ATOXGR == 4 ~ "4", |
| 151 | ! |
ATOXGR == na_level ~ "Missing" |
| 152 |
)), |
|
| 153 | ! |
BTOXGR_GP = factor(dplyr::case_when( |
| 154 | ! |
BTOXGR %in% c(0, -1, -2, -3, -4) ~ "Not High", |
| 155 | ! |
BTOXGR == 1 ~ "1", |
| 156 | ! |
BTOXGR == 2 ~ "2", |
| 157 | ! |
BTOXGR == 3 ~ "3", |
| 158 | ! |
BTOXGR == 4 ~ "4", |
| 159 | ! |
BTOXGR == na_level ~ "Missing" |
| 160 |
)) |
|
| 161 |
), |
|
| 162 | ! |
env = list( |
| 163 | ! |
dataname = as.name("anl"),
|
| 164 | ! |
ATOXGR = as.name(anl_toxgrade_var), |
| 165 | ! |
BTOXGR = as.name(base_toxgrade_var), |
| 166 | ! |
na_level = na_level |
| 167 |
) |
|
| 168 |
) |
|
| 169 |
) |
|
| 170 |
} |
|
| 171 |
} else {
|
|
| 172 | ! |
if (worst_flag_var %in% c("WGRLOVFL", "WGRLOFL")) {
|
| 173 | ! |
data_list <- add_expr( |
| 174 | ! |
data_list, |
| 175 | ! |
substitute( |
| 176 | ! |
dataname <- dplyr::mutate(dataname, |
| 177 | ! |
ATOXGR_GP = factor(dplyr::case_when( |
| 178 | ! |
ATOXGR %in% c(0, 1, 2, 3, 4) ~ "Not Low", |
| 179 | ! |
ATOXGR == -1 ~ "1", |
| 180 | ! |
ATOXGR == -2 ~ "2", |
| 181 | ! |
ATOXGR == -3 ~ "3", |
| 182 | ! |
ATOXGR == -4 ~ "4", |
| 183 | ! |
ATOXGR == na_level ~ "Missing" |
| 184 |
)), |
|
| 185 | ! |
BTOXGR_GP = factor(dplyr::case_when( |
| 186 | ! |
BTOXGR %in% c(0, 1, 2, 3, 4, na_level) ~ "Not Low", |
| 187 | ! |
BTOXGR == -1 ~ "1", |
| 188 | ! |
BTOXGR == -2 ~ "2", |
| 189 | ! |
BTOXGR == -3 ~ "3", |
| 190 | ! |
BTOXGR == -4 ~ "4" |
| 191 |
)) |
|
| 192 |
), |
|
| 193 | ! |
env = list( |
| 194 | ! |
dataname = as.name("anl"),
|
| 195 | ! |
ATOXGR = as.name(anl_toxgrade_var), |
| 196 | ! |
BTOXGR = as.name(base_toxgrade_var), |
| 197 | ! |
na_level = na_level |
| 198 |
) |
|
| 199 |
) |
|
| 200 |
) |
|
| 201 |
} else {
|
|
| 202 | ! |
data_list <- add_expr( |
| 203 | ! |
data_list, |
| 204 | ! |
substitute( |
| 205 | ! |
dataname <- dplyr::mutate(dataname, |
| 206 | ! |
ATOXGR_GP = factor(dplyr::case_when( |
| 207 | ! |
ATOXGR %in% c(0, -1, -2, -3, -4) ~ "Not High", |
| 208 | ! |
ATOXGR == 1 ~ "1", |
| 209 | ! |
ATOXGR == 2 ~ "2", |
| 210 | ! |
ATOXGR == 3 ~ "3", |
| 211 | ! |
ATOXGR == 4 ~ "4", |
| 212 | ! |
ATOXGR == na_level ~ "Missing" |
| 213 |
)), |
|
| 214 | ! |
BTOXGR_GP = factor(dplyr::case_when( |
| 215 | ! |
BTOXGR %in% c(0, -1, -2, -3, -4, na_level) ~ "Not High", |
| 216 | ! |
BTOXGR == 1 ~ "1", |
| 217 | ! |
BTOXGR == 2 ~ "2", |
| 218 | ! |
BTOXGR == 3 ~ "3", |
| 219 | ! |
BTOXGR == 4 ~ "4" |
| 220 |
)) |
|
| 221 |
), |
|
| 222 | ! |
env = list( |
| 223 | ! |
dataname = as.name("anl"),
|
| 224 | ! |
ATOXGR = as.name(anl_toxgrade_var), |
| 225 | ! |
BTOXGR = as.name(base_toxgrade_var), |
| 226 | ! |
na_level = na_level |
| 227 |
) |
|
| 228 |
) |
|
| 229 |
) |
|
| 230 |
} |
|
| 231 |
} |
|
| 232 | ||
| 233 | 3x |
data_list <- add_expr( |
| 234 | 3x |
data_list, |
| 235 | 3x |
substitute( |
| 236 | 3x |
dataname <- dplyr::mutate( |
| 237 | 3x |
dataname, |
| 238 | 3x |
ATOXGR_GP = factor( |
| 239 | 3x |
ATOXGR_GP, |
| 240 | 3x |
levels = c( |
| 241 | 3x |
dplyr::if_else( |
| 242 | 3x |
worst_flag_var %in% c("WGRLOVFL", "WGRLOFL"), "Not Low", "Not High"
|
| 243 | 3x |
), "1", "2", "3", "4", "Missing" |
| 244 |
) |
|
| 245 |
), |
|
| 246 | 3x |
BTOXGR_GP = factor( |
| 247 | 3x |
BTOXGR_GP, |
| 248 | 3x |
levels = c( |
| 249 | 3x |
dplyr::if_else(worst_flag_var %in% c("WGRLOVFL", "WGRLOFL"), "Not Low", "Not High"),
|
| 250 | 3x |
"1", |
| 251 | 3x |
"2", |
| 252 | 3x |
"3", |
| 253 | 3x |
"4", |
| 254 | 3x |
"Missing" |
| 255 |
) |
|
| 256 |
) |
|
| 257 |
), |
|
| 258 | 3x |
env = list( |
| 259 | 3x |
dataname = as.name("anl"),
|
| 260 | 3x |
worst_flag_var = worst_flag_var |
| 261 |
) |
|
| 262 |
) |
|
| 263 |
) |
|
| 264 | ||
| 265 | 3x |
data_list <- add_expr( |
| 266 | 3x |
data_list, |
| 267 | 3x |
substitute( |
| 268 | 3x |
expr = {
|
| 269 | 1x |
column_labels <- list( |
| 270 | 1x |
PARAMCD = teal.data::col_labels(dataname, fill = FALSE)[[paramcd]], |
| 271 | 1x |
AVISIT = teal.data::col_labels(dataname, fill = FALSE)[[visit_var]], |
| 272 | 1x |
ATOXGR_GP = dplyr::if_else(by_visit_fl, "Grade at Visit", "Post-baseline Grade"), |
| 273 | 1x |
BTOXGR_GP = "Baseline Grade" |
| 274 |
) |
|
| 275 | 1x |
teal.data::col_labels(dataname)[names(column_labels)] <- as.character(column_labels) |
| 276 | 1x |
dataname |
| 277 |
}, |
|
| 278 | 3x |
env = list( |
| 279 | 3x |
dataname = as.name("anl"),
|
| 280 | 3x |
paramcd = paramcd, |
| 281 | 3x |
visit_var = visit_var, |
| 282 | 3x |
by_visit_fl = by_visit_fl |
| 283 |
) |
|
| 284 |
) |
|
| 285 |
) |
|
| 286 | ||
| 287 | 3x |
y$data <- bracket_expr(data_list) |
| 288 | ||
| 289 |
# layout start |
|
| 290 | 3x |
y$layout_prep <- quote(split_fun <- drop_split_levels) |
| 291 | ||
| 292 | 3x |
basic_table_args$title <- "Grade Summary Table" |
| 293 | 3x |
basic_table_args$subtitles <- paste("Worst Flag Variable:", worst_flag_var)
|
| 294 | ||
| 295 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 296 | 3x |
teal.widgets::resolve_basic_table_args( |
| 297 | 3x |
user_table = basic_table_args, |
| 298 | 3x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE) |
| 299 |
) |
|
| 300 |
) |
|
| 301 | ||
| 302 | 3x |
layout_list <- list() |
| 303 | 3x |
layout_list <- add_expr( |
| 304 | 3x |
layout_list, |
| 305 | 3x |
if (add_total) {
|
| 306 | ! |
substitute( |
| 307 | ! |
expr = expr_basic_table_args %>% |
| 308 | ! |
rtables::split_cols_by( |
| 309 | ! |
var = arm_var, |
| 310 | ! |
split_fun = add_overall_level(total_label, first = FALSE) |
| 311 |
), |
|
| 312 | ! |
env = list( |
| 313 | ! |
arm_var = arm_var, |
| 314 | ! |
total_label = total_label, |
| 315 | ! |
expr_basic_table_args = parsed_basic_table_args |
| 316 |
) |
|
| 317 |
) |
|
| 318 |
} else {
|
|
| 319 | 3x |
substitute( |
| 320 | 3x |
expr = expr_basic_table_args %>% |
| 321 | 3x |
rtables::split_cols_by(var = arm_var), |
| 322 | 3x |
env = list(arm_var = arm_var, expr_basic_table_args = parsed_basic_table_args) |
| 323 |
) |
|
| 324 |
} |
|
| 325 |
) |
|
| 326 | ||
| 327 | 3x |
split_label <- substitute( |
| 328 | 3x |
expr = teal.data::col_labels(dataname, fill = FALSE)[[paramcd]], |
| 329 | 3x |
env = list( |
| 330 | 3x |
dataname = as.name("anl"),
|
| 331 | 3x |
paramcd = paramcd |
| 332 |
) |
|
| 333 |
) |
|
| 334 | ||
| 335 | 3x |
layout_list <- add_expr( |
| 336 | 3x |
layout_list, |
| 337 | 3x |
substitute( |
| 338 | 3x |
expr = rtables::split_rows_by( |
| 339 | 3x |
var = paramcd, |
| 340 | 3x |
split_fun = split_fun, |
| 341 | 3x |
label_pos = "topleft", |
| 342 | 3x |
split_label = split_label |
| 343 |
), |
|
| 344 | 3x |
env = list( |
| 345 | 3x |
paramcd = paramcd, |
| 346 | 3x |
split_label = split_label |
| 347 |
) |
|
| 348 |
) |
|
| 349 |
) |
|
| 350 | ||
| 351 | 3x |
if (by_visit_fl) {
|
| 352 | 3x |
split_label <- substitute( |
| 353 | 3x |
expr = teal.data::col_labels(dataname, fill = FALSE)[[visit_var]], |
| 354 | 3x |
env = list( |
| 355 | 3x |
dataname = as.name("anl"),
|
| 356 | 3x |
visit_var = visit_var |
| 357 |
) |
|
| 358 |
) |
|
| 359 | ||
| 360 | 3x |
layout_list <- add_expr( |
| 361 | 3x |
layout_list, |
| 362 | 3x |
substitute( |
| 363 | 3x |
expr = rtables::split_rows_by( |
| 364 | 3x |
visit_var, |
| 365 | 3x |
split_fun = split_fun, |
| 366 | 3x |
label_pos = "topleft", |
| 367 | 3x |
split_label = split_label |
| 368 |
), |
|
| 369 | 3x |
env = list( |
| 370 | 3x |
visit_var = visit_var, |
| 371 | 3x |
split_label = split_label |
| 372 |
) |
|
| 373 |
) |
|
| 374 |
) |
|
| 375 |
} |
|
| 376 | ||
| 377 | 3x |
if (by_visit_fl) {
|
| 378 | 3x |
by_var_gp <- "ATOXGR_GP" |
| 379 |
} else {
|
|
| 380 | ! |
by_var_gp <- "BTOXGR_GP" |
| 381 |
} |
|
| 382 | ||
| 383 | 3x |
split_label <- substitute( |
| 384 | 3x |
expr = teal.data::col_labels(dataname, fill = FALSE)[[by_var_gp]], |
| 385 | 3x |
env = list( |
| 386 | 3x |
dataname = as.name("anl"),
|
| 387 | 3x |
by_var_gp = by_var_gp |
| 388 |
) |
|
| 389 |
) |
|
| 390 | 3x |
layout_list <- add_expr( |
| 391 | 3x |
layout_list, |
| 392 | 3x |
substitute( |
| 393 | 3x |
expr = rtables::split_rows_by( |
| 394 | 3x |
var = by_var_gp, |
| 395 | 3x |
split_fun = split_fun, |
| 396 | 3x |
label_pos = "topleft", |
| 397 | 3x |
split_label = split_label |
| 398 |
), |
|
| 399 | 3x |
env = list( |
| 400 | 3x |
by_var_gp = by_var_gp, |
| 401 | 3x |
split_label = split_label |
| 402 |
) |
|
| 403 |
) |
|
| 404 |
) |
|
| 405 | ||
| 406 | 3x |
layout_list <- add_expr( |
| 407 | 3x |
layout_list, |
| 408 | 3x |
substitute( |
| 409 | 3x |
expr = summarize_num_patients( |
| 410 | 3x |
var = id_var, |
| 411 | 3x |
.stats = c("unique_count")
|
| 412 |
), |
|
| 413 | 3x |
env = list( |
| 414 | 3x |
id_var = id_var |
| 415 |
) |
|
| 416 |
) |
|
| 417 |
) |
|
| 418 | ||
| 419 | 3x |
count_var <- setdiff(c("ATOXGR_GP", "BTOXGR_GP"), by_var_gp)
|
| 420 | ||
| 421 | 3x |
if (by_visit_fl) {
|
| 422 | 3x |
indent <- 3L |
| 423 |
} else {
|
|
| 424 | ! |
indent <- 2L |
| 425 |
} |
|
| 426 | ||
| 427 | 3x |
layout_list <- add_expr( |
| 428 | 3x |
layout_list, |
| 429 | 3x |
substitute( |
| 430 | 3x |
expr = count_occurrences( |
| 431 | 3x |
vars = count_var, |
| 432 | 3x |
denom = "n", |
| 433 | 3x |
drop = TRUE, |
| 434 | 3x |
.indent_mods = 4L |
| 435 |
) %>% |
|
| 436 | 3x |
append_varlabels(dataname, count_var, indent = indent), |
| 437 | 3x |
env = list( |
| 438 | 3x |
count_var = count_var, |
| 439 | 3x |
dataname = as.name("anl"),
|
| 440 | 3x |
indent = indent |
| 441 |
) |
|
| 442 |
) |
|
| 443 |
) |
|
| 444 | ||
| 445 | 3x |
y$layout <- substitute( |
| 446 | 3x |
expr = lyt <- layout_pipe, |
| 447 | 3x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 448 |
) |
|
| 449 | ||
| 450 | 3x |
y$table <- substitute( |
| 451 | 3x |
expr = {
|
| 452 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) %>% |
| 453 | ! |
rtables::prune_table() |
| 454 | ! |
result |
| 455 |
}, |
|
| 456 | 3x |
env = list(parent = as.name(parentname)) |
| 457 |
) |
|
| 458 | ||
| 459 | 3x |
y |
| 460 |
} |
|
| 461 | ||
| 462 |
#' teal Module: Grade Summary Table |
|
| 463 |
#' |
|
| 464 |
#' This module produces a summary table of worst grades per subject by visit and parameter. |
|
| 465 |
#' |
|
| 466 |
#' @inheritParams module_arguments |
|
| 467 |
#' @inheritParams template_shift_by_grade |
|
| 468 |
#' @param anl_toxgrade_var ([teal.transform::choices_selected()])\cr |
|
| 469 |
#' variable for analysis toxicity grade. |
|
| 470 |
#' @param base_toxgrade_var ([teal.transform::choices_selected()])\cr |
|
| 471 |
#' variable for baseline toxicity grade. |
|
| 472 |
#' |
|
| 473 |
#' @inherit module_arguments return seealso |
|
| 474 |
#' |
|
| 475 |
#' @examples |
|
| 476 |
#' ADSL <- tmc_ex_adsl |
|
| 477 |
#' ADLB <- tmc_ex_adlb |
|
| 478 |
#' |
|
| 479 |
#' app <- init( |
|
| 480 |
#' data = cdisc_data( |
|
| 481 |
#' ADSL = ADSL, |
|
| 482 |
#' ADLB = ADLB, |
|
| 483 |
#' code = " |
|
| 484 |
#' ADSL <- tmc_ex_adsl |
|
| 485 |
#' ADLB <- tmc_ex_adlb |
|
| 486 |
#' " |
|
| 487 |
#' ), |
|
| 488 |
#' modules = modules( |
|
| 489 |
#' tm_t_shift_by_grade( |
|
| 490 |
#' label = "Grade Laboratory Abnormality Table", |
|
| 491 |
#' dataname = "ADLB", |
|
| 492 |
#' arm_var = choices_selected( |
|
| 493 |
#' choices = variable_choices(ADSL, subset = c("ARM", "ARMCD")),
|
|
| 494 |
#' selected = "ARM" |
|
| 495 |
#' ), |
|
| 496 |
#' paramcd = choices_selected( |
|
| 497 |
#' choices = value_choices(ADLB, "PARAMCD", "PARAM"), |
|
| 498 |
#' selected = "ALT" |
|
| 499 |
#' ), |
|
| 500 |
#' worst_flag_var = choices_selected( |
|
| 501 |
#' choices = variable_choices(ADLB, subset = c("WGRLOVFL", "WGRLOFL", "WGRHIVFL", "WGRHIFL")),
|
|
| 502 |
#' selected = c("WGRLOVFL")
|
|
| 503 |
#' ), |
|
| 504 |
#' worst_flag_indicator = choices_selected( |
|
| 505 |
#' value_choices(ADLB, "WGRLOVFL"), |
|
| 506 |
#' selected = "Y", fixed = TRUE |
|
| 507 |
#' ), |
|
| 508 |
#' anl_toxgrade_var = choices_selected( |
|
| 509 |
#' choices = variable_choices(ADLB, subset = c("ATOXGR")),
|
|
| 510 |
#' selected = c("ATOXGR"),
|
|
| 511 |
#' fixed = TRUE |
|
| 512 |
#' ), |
|
| 513 |
#' base_toxgrade_var = choices_selected( |
|
| 514 |
#' choices = variable_choices(ADLB, subset = c("BTOXGR")),
|
|
| 515 |
#' selected = c("BTOXGR"),
|
|
| 516 |
#' fixed = TRUE |
|
| 517 |
#' ), |
|
| 518 |
#' add_total = FALSE |
|
| 519 |
#' ) |
|
| 520 |
#' ), |
|
| 521 |
#' filter = teal_slices(teal_slice("ADSL", "SAFFL", selected = "Y"))
|
|
| 522 |
#' ) |
|
| 523 |
#' if (interactive()) {
|
|
| 524 |
#' shinyApp(app$ui, app$server) |
|
| 525 |
#' } |
|
| 526 |
#' |
|
| 527 |
#' @export |
|
| 528 |
tm_t_shift_by_grade <- function(label, |
|
| 529 |
dataname, |
|
| 530 |
parentname = ifelse( |
|
| 531 |
inherits(arm_var, "data_extract_spec"), |
|
| 532 |
teal.transform::datanames_input(arm_var), |
|
| 533 |
"ADSL" |
|
| 534 |
), |
|
| 535 |
arm_var, |
|
| 536 |
visit_var = teal.transform::choices_selected( |
|
| 537 |
teal.transform::variable_choices(dataname, subset = "AVISIT"), |
|
| 538 |
selected = "AVISIT", fixed = TRUE |
|
| 539 |
), |
|
| 540 |
paramcd, |
|
| 541 |
worst_flag_var = teal.transform::choices_selected( |
|
| 542 |
teal.transform::variable_choices(dataname, subset = c( |
|
| 543 |
"WGRLOVFL", "WGRLOFL", "WGRHIVFL", "WGRHIFL" |
|
| 544 |
)), |
|
| 545 |
selected = "WGRLOVFL" |
|
| 546 |
), |
|
| 547 |
worst_flag_indicator = teal.transform::choices_selected( |
|
| 548 |
teal.transform::value_choices(dataname, "WGRLOVFL"), |
|
| 549 |
selected = "Y", fixed = TRUE |
|
| 550 |
), |
|
| 551 |
anl_toxgrade_var = teal.transform::choices_selected( |
|
| 552 |
teal.transform::variable_choices(dataname, subset = c("ATOXGR")),
|
|
| 553 |
selected = c("ATOXGR"), fixed = TRUE
|
|
| 554 |
), |
|
| 555 |
base_toxgrade_var = teal.transform::choices_selected( |
|
| 556 |
teal.transform::variable_choices(dataname, subset = c("BTOXGR")),
|
|
| 557 |
selected = c("BTOXGR"), fixed = TRUE
|
|
| 558 |
), |
|
| 559 |
id_var = teal.transform::choices_selected( |
|
| 560 |
teal.transform::variable_choices(dataname, subset = "USUBJID"), |
|
| 561 |
selected = "USUBJID", fixed = TRUE |
|
| 562 |
), |
|
| 563 |
add_total = FALSE, |
|
| 564 |
total_label = default_total_label(), |
|
| 565 |
drop_arm_levels = TRUE, |
|
| 566 |
pre_output = NULL, |
|
| 567 |
post_output = NULL, |
|
| 568 |
na_level = default_na_str(), |
|
| 569 |
code_missing_baseline = FALSE, |
|
| 570 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 571 | ! |
message("Initializing tm_t_shift_by_grade")
|
| 572 | ! |
checkmate::assert_string(label) |
| 573 | ! |
checkmate::assert_string(dataname) |
| 574 | ! |
checkmate::assert_string(parentname) |
| 575 | ! |
checkmate::assert_string(na_level) |
| 576 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 577 | ! |
checkmate::assert_class(visit_var, "choices_selected") |
| 578 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 579 | ! |
checkmate::assert_class(worst_flag_var, "choices_selected") |
| 580 | ! |
checkmate::assert_class(worst_flag_indicator, "choices_selected") |
| 581 | ! |
checkmate::assert_class(anl_toxgrade_var, "choices_selected") |
| 582 | ! |
checkmate::assert_class(base_toxgrade_var, "choices_selected") |
| 583 | ! |
checkmate::assert_class(id_var, "choices_selected") |
| 584 | ! |
checkmate::assert_flag(add_total) |
| 585 | ! |
checkmate::assert_string(total_label) |
| 586 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 587 | ! |
checkmate::assert_flag(code_missing_baseline) |
| 588 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 589 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 590 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 591 | ||
| 592 | ! |
args <- as.list(environment()) |
| 593 | ||
| 594 | ! |
data_extract_list <- list( |
| 595 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 596 | ! |
id_var = cs_to_des_select(id_var, dataname = dataname), |
| 597 | ! |
visit_var = cs_to_des_select(visit_var, dataname = dataname), |
| 598 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname, multiple = TRUE), |
| 599 | ! |
worst_flag_var = cs_to_des_select(worst_flag_var, dataname = dataname), |
| 600 | ! |
anl_toxgrade_var = cs_to_des_select(anl_toxgrade_var, dataname = dataname), |
| 601 | ! |
base_toxgrade_var = cs_to_des_select(base_toxgrade_var, dataname = dataname) |
| 602 |
) |
|
| 603 | ||
| 604 | ! |
module( |
| 605 | ! |
label = label, |
| 606 | ! |
ui = ui_t_shift_by_grade, |
| 607 | ! |
server = srv_t_shift_by_grade, |
| 608 | ! |
ui_args = c(data_extract_list, args), |
| 609 | ! |
server_args = c( |
| 610 | ! |
data_extract_list, |
| 611 | ! |
list( |
| 612 | ! |
dataname = dataname, |
| 613 | ! |
parentname = parentname, |
| 614 | ! |
label = label, |
| 615 | ! |
total_label = total_label, |
| 616 | ! |
na_level = na_level, |
| 617 | ! |
basic_table_args = basic_table_args |
| 618 |
) |
|
| 619 |
), |
|
| 620 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 621 |
) |
|
| 622 |
} |
|
| 623 | ||
| 624 |
#' @keywords internal |
|
| 625 |
ui_t_shift_by_grade <- function(id, ...) {
|
|
| 626 | ! |
ns <- NS(id) |
| 627 | ! |
a <- list(...) # module args |
| 628 | ||
| 629 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 630 | ! |
a$arm_var, |
| 631 | ! |
a$id_var, |
| 632 | ! |
a$visit_var, |
| 633 | ! |
a$paramcd, |
| 634 | ! |
a$worst_flag_var, |
| 635 | ! |
a$worst_flag_indicator, |
| 636 | ! |
a$anl_toxgrade_var, |
| 637 | ! |
a$base_toxgrade_var |
| 638 |
) |
|
| 639 | ||
| 640 | ! |
teal.widgets::standard_layout( |
| 641 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("table"))),
|
| 642 | ! |
encoding = tags$div( |
| 643 |
### Reporter |
|
| 644 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 645 |
### |
|
| 646 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 647 | ! |
teal.transform::datanames_input( |
| 648 | ! |
a[c("arm_var", "id_var", "visit_var", "paramcd", "worst_flag_var", "anl_toxgrade_var", "base_toxgrade_var")]
|
| 649 |
), |
|
| 650 | ! |
teal.transform::data_extract_ui( |
| 651 | ! |
id = ns("arm_var"),
|
| 652 | ! |
label = "Select Treatment Variable", |
| 653 | ! |
data_extract_spec = a$arm_var, |
| 654 | ! |
is_single_dataset = is_single_dataset_value |
| 655 |
), |
|
| 656 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = FALSE),
|
| 657 | ! |
teal.transform::data_extract_ui( |
| 658 | ! |
id = ns("paramcd"),
|
| 659 | ! |
label = "Select Lab Parameter", |
| 660 | ! |
data_extract_spec = a$paramcd, |
| 661 | ! |
is_single_dataset = is_single_dataset_value |
| 662 |
), |
|
| 663 | ! |
teal.transform::data_extract_ui( |
| 664 | ! |
id = ns("worst_flag_var"),
|
| 665 | ! |
label = "Worst flag variable", |
| 666 | ! |
data_extract_spec = a$worst_flag_var, |
| 667 | ! |
is_single_dataset = is_single_dataset_value |
| 668 |
), |
|
| 669 | ! |
teal.transform::data_extract_ui( |
| 670 | ! |
id = ns("visit_var"),
|
| 671 | ! |
label = "Analysis Visit", |
| 672 | ! |
data_extract_spec = a$visit_var, |
| 673 | ! |
is_single_dataset = is_single_dataset_value |
| 674 |
), |
|
| 675 | ! |
teal.transform::data_extract_ui( |
| 676 | ! |
id = ns("anl_toxgrade_var"),
|
| 677 | ! |
label = "Analysis toxicity grade", |
| 678 | ! |
data_extract_spec = a$anl_toxgrade_var, |
| 679 | ! |
is_single_dataset = is_single_dataset_value |
| 680 |
), |
|
| 681 | ! |
teal.transform::data_extract_ui( |
| 682 | ! |
id = ns("base_toxgrade_var"),
|
| 683 | ! |
label = "Baseline toxicity grade", |
| 684 | ! |
data_extract_spec = a$base_toxgrade_var, |
| 685 | ! |
is_single_dataset = is_single_dataset_value |
| 686 |
), |
|
| 687 | ! |
teal.widgets::panel_group( |
| 688 | ! |
teal.widgets::panel_item( |
| 689 | ! |
"Additional table settings", |
| 690 | ! |
checkboxInput( |
| 691 | ! |
ns("drop_arm_levels"),
|
| 692 | ! |
label = "Drop columns not in filtered analysis dataset", |
| 693 | ! |
value = a$drop_arm_levels |
| 694 |
), |
|
| 695 | ! |
checkboxInput( |
| 696 | ! |
ns("code_missing_baseline"),
|
| 697 | ! |
label = "Code missing baseline records as grade 0", |
| 698 | ! |
value = a$code_missing_baseline |
| 699 |
) |
|
| 700 |
) |
|
| 701 |
), |
|
| 702 | ! |
teal.widgets::panel_group( |
| 703 | ! |
teal.widgets::panel_item( |
| 704 | ! |
"Additional Variables Info", |
| 705 | ! |
teal.transform::data_extract_ui( |
| 706 | ! |
id = ns("id_var"),
|
| 707 | ! |
label = "Subject Identifier", |
| 708 | ! |
data_extract_spec = a$id_var, |
| 709 | ! |
is_single_dataset = is_single_dataset_value |
| 710 |
), |
|
| 711 | ! |
teal.widgets::optionalSelectInput( |
| 712 | ! |
ns("worst_flag_indicator"),
|
| 713 | ! |
label = "Value Indicating Worst Grade", |
| 714 | ! |
choices = a$worst_flag_indicator$choices, |
| 715 | ! |
selected = a$worst_flag_indicator$selected, |
| 716 | ! |
multiple = FALSE, |
| 717 | ! |
fixed = a$worst_flag_indicator$fixed |
| 718 |
) |
|
| 719 |
) |
|
| 720 |
) |
|
| 721 |
), |
|
| 722 | ! |
forms = tagList( |
| 723 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 724 |
), |
|
| 725 | ! |
pre_output = a$pre_output, |
| 726 | ! |
post_output = a$post_output |
| 727 |
) |
|
| 728 |
} |
|
| 729 | ||
| 730 |
#' @keywords internal |
|
| 731 |
srv_t_shift_by_grade <- function(id, |
|
| 732 |
data, |
|
| 733 |
reporter, |
|
| 734 |
filter_panel_api, |
|
| 735 |
dataname, |
|
| 736 |
parentname, |
|
| 737 |
arm_var, |
|
| 738 |
visit_var, |
|
| 739 |
paramcd, |
|
| 740 |
worst_flag_var, |
|
| 741 |
anl_toxgrade_var, |
|
| 742 |
base_toxgrade_var, |
|
| 743 |
id_var, |
|
| 744 |
add_total, |
|
| 745 |
total_label, |
|
| 746 |
drop_arm_levels, |
|
| 747 |
na_level, |
|
| 748 |
label, |
|
| 749 |
basic_table_args) {
|
|
| 750 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 751 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 752 | ! |
checkmate::assert_class(data, "reactive") |
| 753 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 754 | ||
| 755 | ! |
moduleServer(id, function(input, output, session) {
|
| 756 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 757 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 758 | ! |
data_extract = list( |
| 759 | ! |
arm_var = arm_var, |
| 760 | ! |
visit_var = visit_var, |
| 761 | ! |
id_var = id_var, |
| 762 | ! |
paramcd = paramcd, |
| 763 | ! |
worst_flag_var = worst_flag_var, |
| 764 | ! |
anl_toxgrade_var = anl_toxgrade_var, |
| 765 | ! |
base_toxgrade_var = base_toxgrade_var |
| 766 |
), |
|
| 767 | ! |
datasets = data, |
| 768 | ! |
select_validation_rule = list( |
| 769 | ! |
base_toxgrade_var = shinyvalidate::sv_required("A baseline toxicity grade is required"),
|
| 770 | ! |
anl_toxgrade_var = shinyvalidate::sv_required("An analysis toxicity grade is required"),
|
| 771 | ! |
visit_var = shinyvalidate::sv_required("An analysis visit is required"),
|
| 772 | ! |
arm_var = shinyvalidate::sv_required("A treatment variable is required"),
|
| 773 | ! |
worst_flag_var = shinyvalidate::sv_required("A worst treatment flag is required"),
|
| 774 | ! |
id_var = shinyvalidate::sv_required("A subject identifier is required.")
|
| 775 |
), |
|
| 776 | ! |
filter_validation_rule = list( |
| 777 | ! |
paramcd = shinyvalidate::sv_required("A laboratory parameter is required")
|
| 778 |
) |
|
| 779 |
) |
|
| 780 | ||
| 781 | ! |
iv_r <- reactive({
|
| 782 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 783 | ! |
iv$add_rule("worst_flag_indicator", shinyvalidate::sv_required("Please select the value indicating worst grade."))
|
| 784 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 785 |
}) |
|
| 786 | ||
| 787 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 788 | ! |
datasets = data, |
| 789 | ! |
selector_list = selector_list, |
| 790 | ! |
merge_function = "dplyr::inner_join" |
| 791 |
) |
|
| 792 | ||
| 793 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 794 | ! |
datasets = data, |
| 795 | ! |
data_extract = list(arm_var = arm_var), |
| 796 | ! |
anl_name = "ANL_ADSL" |
| 797 |
) |
|
| 798 | ||
| 799 | ! |
anl_q <- reactive({
|
| 800 | ! |
data() %>% |
| 801 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 802 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 803 |
}) |
|
| 804 | ||
| 805 | ! |
merged <- list( |
| 806 | ! |
anl_input_r = anl_inputs, |
| 807 | ! |
adsl_input_r = adsl_inputs, |
| 808 | ! |
anl_q = anl_q |
| 809 |
) |
|
| 810 | ||
| 811 | ! |
validate_checks <- reactive({
|
| 812 | ! |
teal::validate_inputs(iv_r()) |
| 813 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 814 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 815 | ||
| 816 | ! |
input_arm_var <- names(merged$anl_input_r()$columns_source$arm_var) |
| 817 | ! |
input_id_var <- names(merged$anl_input_r()$columns_source$id_var) |
| 818 | ! |
input_visit_var <- names(merged$anl_input_r()$columns_source$visit_var) |
| 819 | ! |
input_paramcd_var <- names(merged$anl_input_r()$columns_source$paramcd) |
| 820 | ! |
input_paramcd <- unlist(merged$anl_input_r()$filter_info$paramcd[[1]]$selected) |
| 821 | ! |
input_worst_flag_var <- names(merged$anl_input_r()$columns_source$worst_flag_var) |
| 822 | ! |
input_anl_toxgrade_var <- names(merged$anl_input_r()$columns_source$anl_toxgrade_var) |
| 823 | ! |
input_base_toxgrade_var <- names(merged$anl_input_r()$columns_source$base_toxgrade_var) |
| 824 | ||
| 825 |
# validate inputs |
|
| 826 | ! |
validate_standard_inputs( |
| 827 | ! |
adsl = adsl_filtered, |
| 828 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 829 | ! |
anl = anl_filtered, |
| 830 | ! |
anlvars = c( |
| 831 | ! |
"USUBJID", "STUDYID", input_visit_var, input_paramcd_var, input_worst_flag_var, |
| 832 | ! |
input_anl_toxgrade_var, input_base_toxgrade_var |
| 833 |
), |
|
| 834 | ! |
arm_var = input_arm_var |
| 835 |
) |
|
| 836 |
}) |
|
| 837 | ||
| 838 | ! |
all_q <- reactive({
|
| 839 | ! |
validate_checks() |
| 840 | ||
| 841 | ! |
my_calls <- template_shift_by_grade( |
| 842 | ! |
parentname = "ANL_ADSL", |
| 843 | ! |
dataname = "ANL", |
| 844 | ! |
arm_var = names(merged$anl_input_r()$columns_source$arm_var), |
| 845 | ! |
visit_var = names(merged$anl_input_r()$columns_source$visit_var), |
| 846 | ! |
id_var = names(merged$anl_input_r()$columns_source$id_var), |
| 847 | ! |
worst_flag_var = names(merged$anl_input_r()$columns_source$worst_flag_var), |
| 848 | ! |
worst_flag_indicator = input$worst_flag_indicator, |
| 849 | ! |
anl_toxgrade_var = names(merged$anl_input_r()$columns_source$anl_toxgrade_var), |
| 850 | ! |
base_toxgrade_var = names(merged$anl_input_r()$columns_source$base_toxgrade_var), |
| 851 | ! |
paramcd = unlist(paramcd$filter)["vars_selected"], |
| 852 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 853 | ! |
add_total = input$add_total, |
| 854 | ! |
total_label = total_label, |
| 855 | ! |
na_level = na_level, |
| 856 | ! |
code_missing_baseline = input$code_missing_baseline, |
| 857 | ! |
basic_table_args = basic_table_args |
| 858 |
) |
|
| 859 | ||
| 860 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 861 |
}) |
|
| 862 | ||
| 863 |
# Outputs to render. |
|
| 864 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 865 | ||
| 866 | ! |
teal.widgets::table_with_settings_srv( |
| 867 | ! |
id = "table", |
| 868 | ! |
table_r = table_r |
| 869 |
) |
|
| 870 | ||
| 871 |
# Render R code. |
|
| 872 | ! |
teal.widgets::verbatim_popup_srv( |
| 873 | ! |
id = "rcode", |
| 874 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 875 | ! |
title = label |
| 876 |
) |
|
| 877 | ||
| 878 |
### REPORTER |
|
| 879 | ! |
if (with_reporter) {
|
| 880 | ! |
card_fun <- function(comment, label) {
|
| 881 | ! |
card <- teal::report_card_template( |
| 882 | ! |
title = "Grade Summary Table", |
| 883 | ! |
label = label, |
| 884 | ! |
with_filter = with_filter, |
| 885 | ! |
filter_panel_api = filter_panel_api |
| 886 |
) |
|
| 887 | ! |
card$append_text("Table", "header3")
|
| 888 | ! |
card$append_table(table_r()) |
| 889 | ! |
if (!comment == "") {
|
| 890 | ! |
card$append_text("Comment", "header3")
|
| 891 | ! |
card$append_text(comment) |
| 892 |
} |
|
| 893 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 894 | ! |
card |
| 895 |
} |
|
| 896 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 897 |
} |
|
| 898 |
### |
|
| 899 |
}) |
|
| 900 |
} |
| 1 |
#' Template: Event Rates Adjusted for Patient-Years |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table of event rates adjusted for patient-years. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param events_var (`character`)\cr name of the variable for number of observed events. |
|
| 7 |
#' @param label_paramcd (`character`)\cr `paramcd` variable text to use in the table title. |
|
| 8 |
#' |
|
| 9 |
#' @inherit template_arguments return |
|
| 10 |
#' |
|
| 11 |
#' @seealso [tm_t_events_patyear()] |
|
| 12 |
#' |
|
| 13 |
#' @keywords internal |
|
| 14 |
template_events_patyear <- function(dataname, |
|
| 15 |
parentname, |
|
| 16 |
arm_var, |
|
| 17 |
events_var, |
|
| 18 |
label_paramcd, |
|
| 19 |
aval_var = "AVAL", |
|
| 20 |
add_total = TRUE, |
|
| 21 |
total_label = default_total_label(), |
|
| 22 |
na_level = default_na_str(), |
|
| 23 |
control = control_incidence_rate(), |
|
| 24 |
drop_arm_levels = TRUE, |
|
| 25 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 26 | 3x |
checkmate::assert_character(arm_var, min.len = 1, max.len = 2) |
| 27 | ||
| 28 |
# initialize |
|
| 29 | 3x |
y <- list() |
| 30 |
# data |
|
| 31 | 3x |
data_list <- list() |
| 32 | 3x |
data_list <- add_expr( |
| 33 | 3x |
data_list, |
| 34 | 3x |
substitute( |
| 35 | 3x |
expr = anl <- df, |
| 36 | 3x |
env = list(df = as.name(dataname)) |
| 37 |
) |
|
| 38 |
) |
|
| 39 | 3x |
data_list <- add_expr( |
| 40 | 3x |
data_list, |
| 41 | 3x |
prepare_arm_levels( |
| 42 | 3x |
dataname = "anl", |
| 43 | 3x |
parentname = parentname, |
| 44 | 3x |
arm_var = arm_var[[1]], |
| 45 | 3x |
drop_arm_levels = drop_arm_levels |
| 46 |
) |
|
| 47 |
) |
|
| 48 | 3x |
if (length(arm_var) == 2) {
|
| 49 | 1x |
data_list <- add_expr( |
| 50 | 1x |
data_list, |
| 51 | 1x |
prepare_arm_levels( |
| 52 | 1x |
dataname = "anl", |
| 53 | 1x |
parentname = parentname, |
| 54 | 1x |
arm_var = arm_var[[2]], |
| 55 | 1x |
drop_arm_levels = drop_arm_levels |
| 56 |
) |
|
| 57 |
) |
|
| 58 |
} |
|
| 59 | ||
| 60 | 3x |
data_list <- add_expr( |
| 61 | 3x |
data_list, |
| 62 | 3x |
substitute( |
| 63 | 3x |
expr = dataname <- df_explicit_na(dataname, na_level = na_str), |
| 64 | 3x |
env = list(dataname = as.name("anl"), na_str = na_level)
|
| 65 |
) |
|
| 66 |
) |
|
| 67 | 3x |
data_list <- add_expr( |
| 68 | 3x |
data_list, |
| 69 | 3x |
substitute( |
| 70 | 3x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 71 | 3x |
env = list(parentname = as.name(parentname), na_str = na_level) |
| 72 |
) |
|
| 73 |
) |
|
| 74 | ||
| 75 | 3x |
y$data <- bracket_expr(data_list) |
| 76 | ||
| 77 |
# layout |
|
| 78 | 3x |
layout_list <- list() |
| 79 | ||
| 80 | 3x |
basic_title <- tools::toTitleCase(paste("Event Rates Adjusted for Patient-Years by", label_paramcd))
|
| 81 | 3x |
basic_footer <- paste( |
| 82 | 3x |
"CI Method:", |
| 83 | 3x |
if (control$conf_type == "normal") {
|
| 84 | 2x |
"Normal (rate)" |
| 85 | 3x |
} else if (control$conf_type == "normal_log") {
|
| 86 | ! |
"Normal (log rate)" |
| 87 | 3x |
} else if (control$conf_type == "exact") {
|
| 88 | 1x |
"Exact" |
| 89 |
} else {
|
|
| 90 | ! |
"Byar's method" |
| 91 |
} |
|
| 92 |
) |
|
| 93 | ||
| 94 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 95 | 3x |
teal.widgets::resolve_basic_table_args( |
| 96 | 3x |
user_table = basic_table_args, |
| 97 | 3x |
module_table = teal.widgets::basic_table_args( |
| 98 | 3x |
show_colcounts = TRUE, |
| 99 | 3x |
title = basic_title, |
| 100 | 3x |
main_footer = basic_footer |
| 101 |
) |
|
| 102 |
) |
|
| 103 |
) |
|
| 104 | ||
| 105 | 3x |
layout_list <- add_expr( |
| 106 | 3x |
layout_list, |
| 107 | 3x |
substitute( |
| 108 | 3x |
expr = expr_basic_table_args %>% |
| 109 | 3x |
rtables::split_cols_by(var = arm_var), |
| 110 | 3x |
env = list(arm_var = arm_var[[1]], expr_basic_table_args = parsed_basic_table_args) |
| 111 |
) |
|
| 112 |
) |
|
| 113 | ||
| 114 | 3x |
if (length(arm_var) == 2) {
|
| 115 | 1x |
layout_list <- add_expr( |
| 116 | 1x |
layout_list, |
| 117 | 1x |
if (drop_arm_levels) {
|
| 118 | 1x |
substitute( |
| 119 | 1x |
expr = rtables::split_cols_by(nested_col, split_fun = drop_split_levels), |
| 120 | 1x |
env = list(nested_col = arm_var[[2]]) |
| 121 |
) |
|
| 122 |
} else {
|
|
| 123 | ! |
substitute( |
| 124 | ! |
expr = rtables::split_cols_by(nested_col), |
| 125 | ! |
env = list(nested_col = arm_var[[2]]) |
| 126 |
) |
|
| 127 |
} |
|
| 128 |
) |
|
| 129 |
} |
|
| 130 | ||
| 131 | 3x |
if (add_total) {
|
| 132 | 2x |
layout_list <- add_expr( |
| 133 | 2x |
layout_list, |
| 134 | 2x |
substitute( |
| 135 | 2x |
expr = rtables::add_overall_col(label = total_label), |
| 136 | 2x |
env = list(total_label = total_label) |
| 137 |
) |
|
| 138 |
) |
|
| 139 |
} |
|
| 140 | 3x |
layout_list <- add_expr( |
| 141 | 3x |
layout_list, |
| 142 | 3x |
substitute( |
| 143 | 3x |
expr = estimate_incidence_rate( |
| 144 | 3x |
vars = aval_var, |
| 145 | 3x |
n_events = events_var, |
| 146 | 3x |
control = control_incidence_rate( |
| 147 | 3x |
conf_level = conf_level, |
| 148 | 3x |
conf_type = conf_type, |
| 149 | 3x |
input_time_unit = input_time_unit, |
| 150 | 3x |
num_pt_year = num_pt_year |
| 151 |
) |
|
| 152 |
), |
|
| 153 | 3x |
env = list( |
| 154 | 3x |
aval_var = aval_var, |
| 155 | 3x |
events_var = events_var, |
| 156 | 3x |
conf_level = control$conf_level, |
| 157 | 3x |
conf_type = control$conf_type, |
| 158 | 3x |
input_time_unit = control$input_time_unit, |
| 159 | 3x |
num_pt_year = control$num_pt_year |
| 160 |
) |
|
| 161 |
) |
|
| 162 |
) |
|
| 163 | 3x |
y$layout <- substitute( |
| 164 | 3x |
expr = lyt <- layout_pipe, |
| 165 | 3x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 166 |
) |
|
| 167 | ||
| 168 |
# table |
|
| 169 | 3x |
y$table <- substitute( |
| 170 | 3x |
expr = {
|
| 171 | ! |
result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent) |
| 172 | ! |
result |
| 173 |
}, |
|
| 174 | 3x |
env = list(parent = as.name(parentname)) |
| 175 |
) |
|
| 176 | ||
| 177 | 3x |
y |
| 178 |
} |
|
| 179 | ||
| 180 |
#' teal Module: Event Rates Adjusted for Patient-Years |
|
| 181 |
#' |
|
| 182 |
#' This module produces a table of event rates adjusted for patient-years. |
|
| 183 |
#' |
|
| 184 |
#' @inheritParams module_arguments |
|
| 185 |
#' @inheritParams template_events_patyear |
|
| 186 |
#' @param arm_var ([teal.transform::choices_selected()])\cr object with all |
|
| 187 |
#' available choices and preselected option for variable names that can be used as `arm_var`. |
|
| 188 |
#' It defines the grouping variable(s) in the results table. |
|
| 189 |
#' If there are two elements selected for `arm_var`, |
|
| 190 |
#' second variable will be nested under the first variable. |
|
| 191 |
#' @param events_var ([teal.transform::choices_selected()])\cr object with |
|
| 192 |
#' all available choices and preselected option for the variable with all event counts. |
|
| 193 |
#' |
|
| 194 |
#' @inherit module_arguments return seealso |
|
| 195 |
#' |
|
| 196 |
#' @examples |
|
| 197 |
#' library(dplyr) |
|
| 198 |
#' |
|
| 199 |
#' ADSL <- tmc_ex_adsl |
|
| 200 |
#' ADAETTE <- tmc_ex_adaette %>% |
|
| 201 |
#' filter(PARAMCD %in% c("AETTE1", "AETTE2", "AETTE3")) %>%
|
|
| 202 |
#' mutate(is_event = CNSR == 0) %>% |
|
| 203 |
#' mutate(n_events = as.integer(is_event)) |
|
| 204 |
#' |
|
| 205 |
#' # 1. Basic Example |
|
| 206 |
#' |
|
| 207 |
#' app <- init( |
|
| 208 |
#' data = cdisc_data( |
|
| 209 |
#' ADSL = ADSL, |
|
| 210 |
#' ADAETTE = ADAETTE, |
|
| 211 |
#' code = " |
|
| 212 |
#' ADSL <- tmc_ex_adsl |
|
| 213 |
#' ADAETTE <- tmc_ex_adaette %>% |
|
| 214 |
#' filter(PARAMCD %in% c(\"AETTE1\", \"AETTE2\", \"AETTE3\")) %>% |
|
| 215 |
#' mutate(is_event = CNSR == 0) %>% |
|
| 216 |
#' mutate(n_events = as.integer(is_event)) |
|
| 217 |
#' " |
|
| 218 |
#' ), |
|
| 219 |
#' modules = modules( |
|
| 220 |
#' tm_t_events_patyear( |
|
| 221 |
#' label = "AE Rate Adjusted for Patient-Years At Risk Table", |
|
| 222 |
#' dataname = "ADAETTE", |
|
| 223 |
#' arm_var = choices_selected( |
|
| 224 |
#' choices = variable_choices(ADSL, c("ARM", "ARMCD")),
|
|
| 225 |
#' selected = "ARMCD" |
|
| 226 |
#' ), |
|
| 227 |
#' add_total = TRUE, |
|
| 228 |
#' events_var = choices_selected( |
|
| 229 |
#' choices = variable_choices(ADAETTE, "n_events"), |
|
| 230 |
#' selected = "n_events", |
|
| 231 |
#' fixed = TRUE |
|
| 232 |
#' ), |
|
| 233 |
#' paramcd = choices_selected( |
|
| 234 |
#' choices = value_choices(ADAETTE, "PARAMCD", "PARAM"), |
|
| 235 |
#' selected = "AETTE1" |
|
| 236 |
#' ) |
|
| 237 |
#' ) |
|
| 238 |
#' ) |
|
| 239 |
#' ) |
|
| 240 |
#' if (interactive()) {
|
|
| 241 |
#' shinyApp(app$ui, app$server) |
|
| 242 |
#' } |
|
| 243 |
#' |
|
| 244 |
#' # 2. Example with table split on 2 arm_var variables |
|
| 245 |
#' |
|
| 246 |
#' app <- init( |
|
| 247 |
#' data = cdisc_data( |
|
| 248 |
#' ADSL = ADSL, |
|
| 249 |
#' ADAETTE = ADAETTE, |
|
| 250 |
#' code = " |
|
| 251 |
#' ADSL <- tmc_ex_adsl |
|
| 252 |
#' ADAETTE <- tmc_ex_adaette %>% |
|
| 253 |
#' filter(PARAMCD %in% c(\"AETTE1\", \"AETTE2\", \"AETTE3\")) %>% |
|
| 254 |
#' mutate(is_event = CNSR == 0) %>% |
|
| 255 |
#' mutate(n_events = as.integer(is_event)) |
|
| 256 |
#' " |
|
| 257 |
#' ), |
|
| 258 |
#' modules = modules( |
|
| 259 |
#' tm_t_events_patyear( |
|
| 260 |
#' label = "AE Rate Adjusted for Patient-Years At Risk Table", |
|
| 261 |
#' dataname = "ADAETTE", |
|
| 262 |
#' arm_var = choices_selected( |
|
| 263 |
#' choices = variable_choices(ADSL, c("ARM", "ARMCD", "SEX")),
|
|
| 264 |
#' selected = c("ARM", "SEX")
|
|
| 265 |
#' ), |
|
| 266 |
#' add_total = TRUE, |
|
| 267 |
#' events_var = choices_selected( |
|
| 268 |
#' choices = variable_choices(ADAETTE, "n_events"), |
|
| 269 |
#' selected = "n_events", |
|
| 270 |
#' fixed = TRUE |
|
| 271 |
#' ), |
|
| 272 |
#' paramcd = choices_selected( |
|
| 273 |
#' choices = value_choices(ADAETTE, "PARAMCD", "PARAM"), |
|
| 274 |
#' selected = "AETTE1" |
|
| 275 |
#' ) |
|
| 276 |
#' ) |
|
| 277 |
#' ) |
|
| 278 |
#' ) |
|
| 279 |
#' if (interactive()) {
|
|
| 280 |
#' shinyApp(app$ui, app$server) |
|
| 281 |
#' } |
|
| 282 |
#' |
|
| 283 |
#' @export |
|
| 284 |
tm_t_events_patyear <- function(label, |
|
| 285 |
dataname, |
|
| 286 |
parentname = ifelse( |
|
| 287 |
inherits(arm_var, "data_extract_spec"), |
|
| 288 |
teal.transform::datanames_input(arm_var), |
|
| 289 |
"ADSL" |
|
| 290 |
), |
|
| 291 |
arm_var, |
|
| 292 |
events_var, |
|
| 293 |
paramcd, |
|
| 294 |
aval_var = teal.transform::choices_selected( |
|
| 295 |
teal.transform::variable_choices(dataname, "AVAL"), "AVAL", |
|
| 296 |
fixed = TRUE |
|
| 297 |
), |
|
| 298 |
avalu_var = teal.transform::choices_selected( |
|
| 299 |
teal.transform::variable_choices(dataname, "AVALU"), "AVALU", |
|
| 300 |
fixed = TRUE |
|
| 301 |
), |
|
| 302 |
add_total = TRUE, |
|
| 303 |
total_label = default_total_label(), |
|
| 304 |
na_level = default_na_str(), |
|
| 305 |
conf_level = teal.transform::choices_selected( |
|
| 306 |
c(0.95, 0.9, 0.8), 0.95, |
|
| 307 |
keep_order = TRUE |
|
| 308 |
), |
|
| 309 |
drop_arm_levels = TRUE, |
|
| 310 |
pre_output = NULL, |
|
| 311 |
post_output = NULL, |
|
| 312 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 313 | ! |
message("Initializing tm_t_events_patyear")
|
| 314 | ! |
checkmate::assert_string(label) |
| 315 | ! |
checkmate::assert_string(dataname) |
| 316 | ! |
checkmate::assert_string(parentname) |
| 317 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 318 | ! |
checkmate::assert_class(events_var, "choices_selected") |
| 319 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 320 | ! |
checkmate::assert_class(aval_var, "choices_selected") |
| 321 | ! |
checkmate::assert_class(avalu_var, "choices_selected") |
| 322 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 323 | ! |
checkmate::assert_flag(add_total) |
| 324 | ! |
checkmate::assert_string(total_label) |
| 325 | ! |
checkmate::assert_string(na_level) |
| 326 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 327 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 328 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 329 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 330 | ||
| 331 | ! |
args <- c(as.list(environment())) |
| 332 | ||
| 333 | ! |
data_extract_list <- list( |
| 334 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname, multiple = TRUE, ordered = TRUE), |
| 335 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 336 | ! |
aval_var = cs_to_des_select(aval_var, dataname = dataname), |
| 337 | ! |
avalu_var = cs_to_des_select(avalu_var, dataname = dataname), |
| 338 | ! |
events_var = cs_to_des_select(events_var, dataname = dataname) |
| 339 |
) |
|
| 340 | ||
| 341 | ! |
module( |
| 342 | ! |
label = label, |
| 343 | ! |
ui = ui_events_patyear, |
| 344 | ! |
ui_args = c(data_extract_list, args), |
| 345 | ! |
server = srv_events_patyear, |
| 346 | ! |
server_args = c( |
| 347 | ! |
data_extract_list, |
| 348 | ! |
list( |
| 349 | ! |
dataname = dataname, |
| 350 | ! |
parentname = parentname, |
| 351 | ! |
label = label, |
| 352 | ! |
total_label = total_label, |
| 353 | ! |
na_level = na_level, |
| 354 | ! |
basic_table_args = basic_table_args |
| 355 |
) |
|
| 356 |
), |
|
| 357 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 358 |
) |
|
| 359 |
} |
|
| 360 | ||
| 361 |
#' @keywords internal |
|
| 362 |
ui_events_patyear <- function(id, ...) {
|
|
| 363 | ! |
ns <- NS(id) |
| 364 | ! |
a <- list(...) |
| 365 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 366 | ! |
a$arm_var, a$paramcd, a$aval_var, a$avalu_var, a$events_var |
| 367 |
) |
|
| 368 | ||
| 369 | ! |
teal.widgets::standard_layout( |
| 370 | ! |
output = teal.widgets::white_small_well(teal.widgets::table_with_settings_ui(ns("patyear_table"))),
|
| 371 | ! |
encoding = tags$div( |
| 372 |
### Reporter |
|
| 373 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 374 |
### |
|
| 375 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 376 | ! |
teal.transform::datanames_input(a[c("arm_var", "paramcd", "aval_var", "avalu_var", "events_var")]),
|
| 377 | ! |
teal.transform::data_extract_ui( |
| 378 | ! |
id = ns("arm_var"),
|
| 379 | ! |
label = "Select Treatment Variable", |
| 380 | ! |
data_extract_spec = a$arm_var, |
| 381 | ! |
is_single_dataset = is_single_dataset_value |
| 382 |
), |
|
| 383 | ! |
checkboxInput(ns("add_total"), "Add All Patients column", value = a$add_total),
|
| 384 | ! |
teal.transform::data_extract_ui( |
| 385 | ! |
id = ns("paramcd"),
|
| 386 | ! |
label = "Select an Event Type Parameter", |
| 387 | ! |
data_extract_spec = a$paramcd, |
| 388 | ! |
is_single_dataset = is_single_dataset_value |
| 389 |
), |
|
| 390 | ! |
teal.transform::data_extract_ui( |
| 391 | ! |
id = ns("aval_var"),
|
| 392 | ! |
label = "Analysis Variable", |
| 393 | ! |
data_extract_spec = a$aval_var, |
| 394 | ! |
is_single_dataset = is_single_dataset_value |
| 395 |
), |
|
| 396 | ! |
teal.transform::data_extract_ui( |
| 397 | ! |
id = ns("events_var"),
|
| 398 | ! |
label = "Event Variable", |
| 399 | ! |
data_extract_spec = a$events_var, |
| 400 | ! |
is_single_dataset = is_single_dataset_value |
| 401 |
), |
|
| 402 | ! |
teal.transform::data_extract_ui( |
| 403 | ! |
id = ns("avalu_var"),
|
| 404 | ! |
label = "Analysis Unit Variable", |
| 405 | ! |
data_extract_spec = a$avalu_var, |
| 406 | ! |
is_single_dataset = is_single_dataset_value |
| 407 |
), |
|
| 408 | ! |
teal.widgets::optionalSelectInput( |
| 409 | ! |
inputId = ns("conf_level"),
|
| 410 | ! |
label = "Confidence Level", |
| 411 | ! |
a$conf_level$choices, |
| 412 | ! |
a$conf_level$selected, |
| 413 | ! |
multiple = FALSE, |
| 414 | ! |
fixed = a$conf_level$fixed |
| 415 |
), |
|
| 416 | ! |
teal.widgets::optionalSelectInput( |
| 417 | ! |
ns("conf_method"),
|
| 418 | ! |
"CI Method", |
| 419 | ! |
choices = c("Normal (rate)", "Normal (log rate)", "Exact", "Byar's method"),
|
| 420 | ! |
selected = "Normal (rate)", |
| 421 | ! |
multiple = FALSE, |
| 422 | ! |
fixed = FALSE |
| 423 |
), |
|
| 424 | ! |
teal.widgets::panel_group( |
| 425 | ! |
teal.widgets::panel_item( |
| 426 | ! |
"Additional table settings", |
| 427 | ! |
checkboxInput( |
| 428 | ! |
ns("drop_arm_levels"),
|
| 429 | ! |
label = "Drop columns not in filtered analysis dataset", |
| 430 | ! |
value = a$drop_arm_levels |
| 431 |
), |
|
| 432 | ! |
teal.widgets::optionalSelectInput( |
| 433 | ! |
ns("num_pt_year"),
|
| 434 | ! |
"Time Unit for AE Rate (in Patient-Years)", |
| 435 | ! |
choices = c(0.1, 1, 10, 100, 1000), |
| 436 | ! |
selected = 100, |
| 437 | ! |
multiple = FALSE, |
| 438 | ! |
fixed = FALSE |
| 439 |
), |
|
| 440 | ! |
selectInput( |
| 441 | ! |
ns("input_time_unit"),
|
| 442 | ! |
"Analysis Unit", |
| 443 | ! |
choices = NULL, |
| 444 | ! |
selected = NULL, |
| 445 | ! |
multiple = FALSE |
| 446 |
) |
|
| 447 |
) |
|
| 448 |
) |
|
| 449 |
), |
|
| 450 | ! |
forms = tagList( |
| 451 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 452 |
), |
|
| 453 | ! |
pre_output = a$pre_output, |
| 454 | ! |
post_output = a$post_output |
| 455 |
) |
|
| 456 |
} |
|
| 457 | ||
| 458 |
#' @keywords internal |
|
| 459 |
srv_events_patyear <- function(id, |
|
| 460 |
data, |
|
| 461 |
reporter, |
|
| 462 |
filter_panel_api, |
|
| 463 |
dataname, |
|
| 464 |
parentname, |
|
| 465 |
arm_var, |
|
| 466 |
paramcd, |
|
| 467 |
aval_var, |
|
| 468 |
avalu_var, |
|
| 469 |
events_var, |
|
| 470 |
add_total, |
|
| 471 |
total_label, |
|
| 472 |
na_level, |
|
| 473 |
drop_arm_levels, |
|
| 474 |
label, |
|
| 475 |
basic_table_args) {
|
|
| 476 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 477 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 478 | ! |
checkmate::assert_class(data, "reactive") |
| 479 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 480 | ||
| 481 | ! |
moduleServer(id, function(input, output, session) {
|
| 482 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 483 | ! |
observeEvent(anl_q(), {
|
| 484 | ! |
data_anl <- merged$anl_q()[["ANL"]] |
| 485 | ! |
aval_unit_var <- merged$anl_input_r()$columns_source$avalu_var |
| 486 | ! |
if (length(aval_unit_var) > 0) {
|
| 487 | ! |
choices <- stats::na.omit(unique(data_anl[[aval_unit_var]])) |
| 488 | ! |
choices <- gsub("s$", "", tolower(choices))
|
| 489 | ||
| 490 | ! |
updateSelectInput( |
| 491 | ! |
session, |
| 492 | ! |
"input_time_unit", |
| 493 | ! |
choices = choices, |
| 494 | ! |
selected = choices[1] |
| 495 |
) |
|
| 496 |
} |
|
| 497 |
}) |
|
| 498 | ||
| 499 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 500 | ! |
data_extract = list( |
| 501 | ! |
arm_var = arm_var, |
| 502 | ! |
paramcd = paramcd, |
| 503 | ! |
aval_var = aval_var, |
| 504 | ! |
avalu_var = avalu_var, |
| 505 | ! |
events_var = events_var |
| 506 |
), |
|
| 507 | ! |
datasets = data, |
| 508 | ! |
select_validation_rule = list( |
| 509 | ! |
arm_var = ~ if (length(.) != 1 && length(.) != 2) "Please select exactly 1 or 2 treatment variables", |
| 510 | ! |
aval_var = shinyvalidate::sv_required("Analysis Variable is required"),
|
| 511 | ! |
events_var = shinyvalidate::sv_required("Events Variable is required")
|
| 512 |
), |
|
| 513 | ! |
filter_validation_rule = list( |
| 514 | ! |
paramcd = shinyvalidate::sv_required("A Event Type Parameter is required")
|
| 515 |
) |
|
| 516 |
) |
|
| 517 | ||
| 518 | ! |
iv_r <- reactive({
|
| 519 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 520 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level"))
|
| 521 | ! |
iv$add_rule( |
| 522 | ! |
"conf_level", |
| 523 | ! |
shinyvalidate::sv_between( |
| 524 | ! |
0, 1, |
| 525 | ! |
inclusive = c(FALSE, FALSE), |
| 526 | ! |
message_fmt = "Confidence level must be between 0 and 1" |
| 527 |
) |
|
| 528 |
) |
|
| 529 | ! |
iv$add_rule("conf_method", shinyvalidate::sv_required("A CI method is required"))
|
| 530 | ! |
iv$add_rule("num_pt_year", shinyvalidate::sv_required("Time Unit for AE Rate is required"))
|
| 531 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 532 |
}) |
|
| 533 | ||
| 534 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 535 | ! |
datasets = data, |
| 536 | ! |
selector_list = selector_list, |
| 537 | ! |
merge_function = "dplyr::inner_join" |
| 538 |
) |
|
| 539 | ||
| 540 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 541 | ! |
datasets = data, |
| 542 | ! |
data_extract = list(arm_var = arm_var), |
| 543 | ! |
anl_name = "ANL_ADSL" |
| 544 |
) |
|
| 545 | ||
| 546 | ! |
anl_q <- reactive({
|
| 547 | ! |
data() %>% |
| 548 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 549 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 550 |
}) |
|
| 551 | ||
| 552 | ! |
merged <- list( |
| 553 | ! |
anl_input_r = anl_inputs, |
| 554 | ! |
adsl_input_r = adsl_inputs, |
| 555 | ! |
anl_q = anl_q |
| 556 |
) |
|
| 557 | ||
| 558 |
# Prepare the analysis environment (filter data, check data, populate envir). |
|
| 559 | ! |
validate_checks <- reactive({
|
| 560 | ! |
teal::validate_inputs(iv_r()) |
| 561 | ! |
adsl_filtered <- merged$anl_q()[[parentname]] |
| 562 | ! |
anl_filtered <- merged$anl_q()[[dataname]] |
| 563 | ||
| 564 | ! |
input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) |
| 565 | ! |
input_aval_var <- as.vector(merged$anl_input_r()$columns_source$aval_var) |
| 566 | ! |
input_avalu_var <- as.vector(merged$anl_input_r()$columns_source$avalu_var) |
| 567 | ! |
input_events_var <- as.vector(merged$anl_input_r()$columns_source$events_var) |
| 568 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 569 | ||
| 570 |
# validate inputs |
|
| 571 | ! |
validate_standard_inputs( |
| 572 | ! |
adsl = adsl_filtered, |
| 573 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 574 | ! |
anl = anl_filtered, |
| 575 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_events_var, input_aval_var, input_avalu_var),
|
| 576 | ! |
arm_var = input_arm_var[[1]] |
| 577 |
) |
|
| 578 | ||
| 579 | ! |
validate( |
| 580 | ! |
need( |
| 581 | ! |
!any(is.na(merged$anl_q()[["ANL"]][[input_events_var]])), |
| 582 | ! |
"`Event Variable` for selected parameter includes NA values." |
| 583 |
) |
|
| 584 |
) |
|
| 585 | ! |
NULL |
| 586 |
}) |
|
| 587 | ||
| 588 |
# The R-code corresponding to the analysis. |
|
| 589 | ! |
table_q <- reactive({
|
| 590 | ! |
validate_checks() |
| 591 | ||
| 592 | ! |
ANL <- merged$anl_q()[["ANL"]] |
| 593 | ! |
label_paramcd <- get_paramcd_label(ANL, paramcd) |
| 594 | ||
| 595 | ! |
my_calls <- template_events_patyear( |
| 596 | ! |
dataname = "ANL", |
| 597 | ! |
parentname = "ANL_ADSL", |
| 598 | ! |
arm_var = as.vector(merged$anl_input_r()$columns_source$arm_var), |
| 599 | ! |
aval_var = as.vector(merged$anl_input_r()$columns_source$aval_var), |
| 600 | ! |
events_var = as.vector(merged$anl_input_r()$columns_source$events_var), |
| 601 | ! |
label_paramcd = label_paramcd, |
| 602 | ! |
add_total = input$add_total, |
| 603 | ! |
total_label = total_label, |
| 604 | ! |
na_level = na_level, |
| 605 | ! |
control = control_incidence_rate( |
| 606 | ! |
conf_level = as.numeric(input$conf_level), |
| 607 | ! |
conf_type = if (input$conf_method == "Normal (rate)") {
|
| 608 | ! |
"normal" |
| 609 | ! |
} else if (input$conf_method == "Normal (log rate)") {
|
| 610 | ! |
"normal_log" |
| 611 | ! |
} else if (input$conf_method == "Exact") {
|
| 612 | ! |
"exact" |
| 613 |
} else {
|
|
| 614 | ! |
"byar" |
| 615 |
}, |
|
| 616 | ! |
input_time_unit = if (input$input_time_unit %in% c("day", "week", "month", "year")) {
|
| 617 | ! |
input$input_time_unit |
| 618 |
} else {
|
|
| 619 | ! |
"year" |
| 620 |
}, |
|
| 621 | ! |
num_pt_year = as.numeric(input$num_pt_year) |
| 622 |
), |
|
| 623 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 624 | ! |
basic_table_args = basic_table_args |
| 625 |
) |
|
| 626 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(my_calls)) |
| 627 |
}) |
|
| 628 | ||
| 629 |
# Outputs to render. |
|
| 630 | ! |
table_r <- reactive({
|
| 631 | ! |
table_q()[["result"]] |
| 632 |
}) |
|
| 633 | ||
| 634 | ! |
teal.widgets::table_with_settings_srv( |
| 635 | ! |
id = "patyear_table", |
| 636 | ! |
table_r = table_r |
| 637 |
) |
|
| 638 | ||
| 639 |
# Render R code. |
|
| 640 | ! |
teal.widgets::verbatim_popup_srv( |
| 641 | ! |
id = "rcode", |
| 642 | ! |
verbatim_content = reactive(teal.code::get_code(table_q())), |
| 643 | ! |
title = label |
| 644 |
) |
|
| 645 | ||
| 646 |
### REPORTER |
|
| 647 | ! |
if (with_reporter) {
|
| 648 | ! |
card_fun <- function(comment, label) {
|
| 649 | ! |
card <- teal::report_card_template( |
| 650 | ! |
title = "Event Rates Adjusted For Patient-Years Table", |
| 651 | ! |
label = label, |
| 652 | ! |
with_filter = with_filter, |
| 653 | ! |
filter_panel_api = filter_panel_api |
| 654 |
) |
|
| 655 | ! |
card$append_text("Table", "header3")
|
| 656 | ! |
card$append_table(table_r()) |
| 657 | ! |
if (!comment == "") {
|
| 658 | ! |
card$append_text("Comment", "header3")
|
| 659 | ! |
card$append_text(comment) |
| 660 |
} |
|
| 661 | ! |
card$append_src(teal.code::get_code(table_q())) |
| 662 | ! |
card |
| 663 |
} |
|
| 664 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 665 |
} |
|
| 666 |
### |
|
| 667 |
}) |
|
| 668 |
} |
| 1 |
#' Template: Patient Profile Adverse Events Table and Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate an adverse events table and [ggplot2::ggplot()] plot using ADaM datasets. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param aeterm (`character`)\cr name of the reported term for the adverse event variable. |
|
| 7 |
#' @param tox_grade (`character`)\cr name of the standard toxicity grade variable. |
|
| 8 |
#' @param causality (`character`)\cr name of the causality variable. |
|
| 9 |
#' @param outcome (`character`)\cr name of outcome of adverse event variable. |
|
| 10 |
#' @param action (`character`)\cr name of action taken with study treatment variable. |
|
| 11 |
#' @param time (`character`)\cr name of study day of start of adverse event variable. |
|
| 12 |
#' @param decod (`character`)\cr name of dictionary derived term variable. |
|
| 13 |
#' |
|
| 14 |
#' @inherit template_arguments return |
|
| 15 |
#' |
|
| 16 |
#' @seealso [tm_g_pp_adverse_events()] |
|
| 17 |
#' |
|
| 18 |
#' @keywords internal |
|
| 19 |
template_adverse_events <- function(dataname = "ANL", |
|
| 20 |
aeterm = "AETERM", |
|
| 21 |
tox_grade = "AETOXGR", |
|
| 22 |
causality = "AEREL", |
|
| 23 |
outcome = "AEOUT", |
|
| 24 |
action = "AEACN", |
|
| 25 |
time = "ASTDY", |
|
| 26 |
decod = NULL, |
|
| 27 |
patient_id, |
|
| 28 |
font_size = 12L, |
|
| 29 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 30 | ! |
checkmate::assert_string(dataname) |
| 31 | ! |
checkmate::assert_string(aeterm) |
| 32 | ! |
checkmate::assert_string(tox_grade) |
| 33 | ! |
checkmate::assert_string(causality) |
| 34 | ! |
checkmate::assert_string(outcome) |
| 35 | ! |
checkmate::assert_string(action) |
| 36 | ! |
checkmate::assert_string(time, null.ok = TRUE) |
| 37 | ! |
checkmate::assert_string(decod, null.ok = TRUE) |
| 38 | ! |
checkmate::assert_string(patient_id) |
| 39 | ! |
checkmate::assert_number(font_size) |
| 40 | ||
| 41 | ! |
y <- list() |
| 42 | ||
| 43 | ! |
y$table <- list() |
| 44 | ! |
y$chart <- list() |
| 45 | ||
| 46 | ! |
table_list <- add_expr( |
| 47 | ! |
list(), |
| 48 | ! |
substitute( |
| 49 | ! |
expr = {
|
| 50 | ! |
table <- dataname %>% |
| 51 | ! |
dplyr::select( |
| 52 | ! |
aeterm, tox_grade, causality, outcome, action, time, decod |
| 53 |
) %>% |
|
| 54 | ! |
dplyr::arrange(dplyr::desc(tox_grade)) %>% |
| 55 | ! |
`colnames<-`(col_labels(dataname, fill = TRUE)[vars]) |
| 56 | ||
| 57 | ! |
table <- rlistings::as_listing( |
| 58 | ! |
table, |
| 59 | ! |
key_cols = NULL, |
| 60 | ! |
default_formatting = list(all = fmt_config(align = "left")) |
| 61 |
) |
|
| 62 | ! |
main_title(table) <- paste("Patient ID:", patient_id)
|
| 63 | ||
| 64 | ! |
table |
| 65 |
}, |
|
| 66 | ! |
env = list( |
| 67 | ! |
dataname = as.name(dataname), |
| 68 | ! |
aeterm = as.name(aeterm), |
| 69 | ! |
tox_grade = as.name(tox_grade), |
| 70 | ! |
causality = as.name(causality), |
| 71 | ! |
outcome = as.name(outcome), |
| 72 | ! |
action = as.name(action), |
| 73 | ! |
time = as.name(time), |
| 74 | ! |
decod = `if`(is.null(decod), NULL, as.name(decod)), |
| 75 | ! |
vars = c(aeterm, tox_grade, causality, outcome, action, time, decod), |
| 76 | ! |
patient_id = patient_id |
| 77 |
) |
|
| 78 |
) |
|
| 79 |
) |
|
| 80 | ||
| 81 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 82 | ! |
teal.widgets::resolve_ggplot2_args( |
| 83 | ! |
user_plot = ggplot2_args, |
| 84 | ! |
module_plot = teal.widgets::ggplot2_args( |
| 85 | ! |
labs = list(y = "Adverse Events", title = paste0("Patient ID: ", patient_id)),
|
| 86 | ! |
theme = list( |
| 87 | ! |
text = substitute(ggplot2::element_text(size = font), list(font = font_size[1])), |
| 88 | ! |
axis.text.y = quote(ggplot2::element_blank()), |
| 89 | ! |
axis.ticks.y = quote(ggplot2::element_blank()), |
| 90 | ! |
legend.position = "right", |
| 91 | ! |
panel.grid.minor = quote(ggplot2::element_line( |
| 92 | ! |
linewidth = 0.5, |
| 93 | ! |
linetype = "dotted", |
| 94 | ! |
colour = "grey" |
| 95 |
)), |
|
| 96 | ! |
panel.grid.major = quote(ggplot2::element_line( |
| 97 | ! |
linewidth = 0.5, |
| 98 | ! |
linetype = "dotted", |
| 99 | ! |
colour = "grey" |
| 100 |
)) |
|
| 101 |
) |
|
| 102 |
) |
|
| 103 |
) |
|
| 104 |
) |
|
| 105 | ||
| 106 | ! |
chart_list <- add_expr( |
| 107 | ! |
list(), |
| 108 | ! |
substitute( |
| 109 | ! |
expr = plot <- dataname %>% |
| 110 | ! |
dplyr::select(aeterm, time, tox_grade, causality) %>% |
| 111 | ! |
dplyr::mutate(ATOXGR = as.character(tox_grade)) %>% |
| 112 | ! |
dplyr::arrange(dplyr::desc(ATOXGR)) %>% |
| 113 | ! |
dplyr::mutate(ATOXGR = dplyr::case_when( |
| 114 | ! |
ATOXGR == "." ~ "UNKNOWN", |
| 115 | ! |
TRUE ~ ATOXGR |
| 116 |
)) %>% |
|
| 117 | ! |
ggplot2::ggplot(ggplot2::aes( |
| 118 | ! |
fill = ATOXGR, color = aeterm, y = aeterm, x = time |
| 119 |
)) + |
|
| 120 | ! |
ggrepel::geom_label_repel( |
| 121 | ! |
ggplot2::aes(label = aeterm), |
| 122 | ! |
color = "black", |
| 123 | ! |
hjust = "right", |
| 124 | ! |
size = font_size_var[1] / 3.5, |
| 125 | ! |
show.legend = FALSE |
| 126 |
) + |
|
| 127 | ! |
ggplot2::scale_fill_manual(values = c( |
| 128 | ! |
"1" = "#E2264633", |
| 129 | ! |
"2" = "#E2264666", |
| 130 | ! |
"3" = "#E2264699", |
| 131 | ! |
"4" = "#E22646CC", |
| 132 | ! |
"5" = "#E22646FF", |
| 133 | ! |
"UNKNOWN" = "#ACADB1FF" |
| 134 |
)) + |
|
| 135 | ! |
ggplot2::scale_y_discrete(expand = ggplot2::expansion(add = 1.2)) + |
| 136 | ! |
ggplot2::xlim(1, 1.2 * max(dataname[[time_var]])) + |
| 137 | ! |
ggplot2::geom_point(color = "black", size = 2, shape = 24, position = ggplot2::position_nudge(y = -0.15)) + |
| 138 | ! |
labs + |
| 139 | ! |
themes, |
| 140 | ! |
env = list( |
| 141 | ! |
dataname = as.name(dataname), |
| 142 | ! |
aeterm = as.name(aeterm), |
| 143 | ! |
time = as.name(time), |
| 144 | ! |
tox_grade = as.name(tox_grade), |
| 145 | ! |
causality = as.name(causality), |
| 146 | ! |
time_var = time, |
| 147 | ! |
font_size_var = font_size, |
| 148 | ! |
patient_id = patient_id, |
| 149 | ! |
labs = parsed_ggplot2_args$labs, |
| 150 | ! |
themes = parsed_ggplot2_args$theme |
| 151 |
) |
|
| 152 |
) |
|
| 153 |
) |
|
| 154 | ||
| 155 | ! |
chart_list <- add_expr( |
| 156 | ! |
expr_ls = chart_list, |
| 157 | ! |
new_expr = quote(print(plot)) |
| 158 |
) |
|
| 159 | ||
| 160 | ! |
y$table <- bracket_expr(table_list) |
| 161 | ! |
y$chart <- bracket_expr(chart_list) |
| 162 | ||
| 163 | ! |
y |
| 164 |
} |
|
| 165 | ||
| 166 |
#' teal Module: Patient Profile Adverse Events Table and Plot |
|
| 167 |
#' |
|
| 168 |
#' This module produces an adverse events table and [ggplot2::ggplot()] type plot using ADaM datasets. |
|
| 169 |
#' |
|
| 170 |
#' @inheritParams module_arguments |
|
| 171 |
#' @inheritParams template_adverse_events |
|
| 172 |
#' @param aeterm ([teal.transform::choices_selected()])\cr object with all |
|
| 173 |
#' available choices and preselected option for the `AETERM` variable from `dataname`. |
|
| 174 |
#' @param tox_grade ([teal.transform::choices_selected()])\cr object with all |
|
| 175 |
#' available choices and preselected option for the `AETOXGR` variable from `dataname`. |
|
| 176 |
#' @param causality ([teal.transform::choices_selected()])\cr object with all |
|
| 177 |
#' available choices and preselected option for the `AEREL` variable from `dataname`. |
|
| 178 |
#' @param outcome ([teal.transform::choices_selected()])\cr object with all |
|
| 179 |
#' available choices and preselected option for the `AEOUT` variable from `dataname`. |
|
| 180 |
#' @param action ([teal.transform::choices_selected()])\cr object with all |
|
| 181 |
#' available choices and preselected option for the `AEACN` variable from `dataname`. |
|
| 182 |
#' @param time ([teal.transform::choices_selected()])\cr object with all |
|
| 183 |
#' available choices and preselected option for the `ASTDY` variable from `dataname`. |
|
| 184 |
#' @param decod ([teal.transform::choices_selected()])\cr object with all |
|
| 185 |
#' available choices and preselected option for the `AEDECOD` variable from `dataname`. |
|
| 186 |
#' |
|
| 187 |
#' @inherit module_arguments return |
|
| 188 |
#' |
|
| 189 |
#' @examples |
|
| 190 |
#' library(nestcolor) |
|
| 191 |
#' library(dplyr) |
|
| 192 |
#' |
|
| 193 |
#' ADAE <- tmc_ex_adae |
|
| 194 |
#' ADSL <- tmc_ex_adsl %>% filter(USUBJID %in% ADAE$USUBJID) |
|
| 195 |
#' |
|
| 196 |
#' app <- init( |
|
| 197 |
#' data = cdisc_data( |
|
| 198 |
#' ADSL = ADSL, |
|
| 199 |
#' ADAE = ADAE, |
|
| 200 |
#' code = " |
|
| 201 |
#' ADAE <- tmc_ex_adae |
|
| 202 |
#' ADSL <- tmc_ex_adsl %>% filter(USUBJID %in% ADAE$USUBJID) |
|
| 203 |
#' " |
|
| 204 |
#' ), |
|
| 205 |
#' modules = modules( |
|
| 206 |
#' tm_g_pp_adverse_events( |
|
| 207 |
#' label = "Adverse Events", |
|
| 208 |
#' dataname = "ADAE", |
|
| 209 |
#' parentname = "ADSL", |
|
| 210 |
#' patient_col = "USUBJID", |
|
| 211 |
#' plot_height = c(600L, 200L, 2000L), |
|
| 212 |
#' aeterm = choices_selected( |
|
| 213 |
#' choices = variable_choices(ADAE, "AETERM"), |
|
| 214 |
#' selected = "AETERM" |
|
| 215 |
#' ), |
|
| 216 |
#' tox_grade = choices_selected( |
|
| 217 |
#' choices = variable_choices(ADAE, "AETOXGR"), |
|
| 218 |
#' selected = "AETOXGR" |
|
| 219 |
#' ), |
|
| 220 |
#' causality = choices_selected( |
|
| 221 |
#' choices = variable_choices(ADAE, "AEREL"), |
|
| 222 |
#' selected = "AEREL" |
|
| 223 |
#' ), |
|
| 224 |
#' outcome = choices_selected( |
|
| 225 |
#' choices = variable_choices(ADAE, "AEOUT"), |
|
| 226 |
#' selected = "AEOUT" |
|
| 227 |
#' ), |
|
| 228 |
#' action = choices_selected( |
|
| 229 |
#' choices = variable_choices(ADAE, "AEACN"), |
|
| 230 |
#' selected = "AEACN" |
|
| 231 |
#' ), |
|
| 232 |
#' time = choices_selected( |
|
| 233 |
#' choices = variable_choices(ADAE, "ASTDY"), |
|
| 234 |
#' selected = "ASTDY" |
|
| 235 |
#' ), |
|
| 236 |
#' decod = NULL |
|
| 237 |
#' ) |
|
| 238 |
#' ) |
|
| 239 |
#' ) |
|
| 240 |
#' if (interactive()) {
|
|
| 241 |
#' shinyApp(app$ui, app$server) |
|
| 242 |
#' } |
|
| 243 |
#' |
|
| 244 |
#' @export |
|
| 245 |
tm_g_pp_adverse_events <- function(label, |
|
| 246 |
dataname = "ADAE", |
|
| 247 |
parentname = "ADSL", |
|
| 248 |
patient_col = "USUBJID", |
|
| 249 |
aeterm = NULL, |
|
| 250 |
tox_grade = NULL, |
|
| 251 |
causality = NULL, |
|
| 252 |
outcome = NULL, |
|
| 253 |
action = NULL, |
|
| 254 |
time = NULL, |
|
| 255 |
decod = NULL, |
|
| 256 |
font_size = c(12L, 12L, 25L), |
|
| 257 |
plot_height = c(700L, 200L, 2000L), |
|
| 258 |
plot_width = NULL, |
|
| 259 |
pre_output = NULL, |
|
| 260 |
post_output = NULL, |
|
| 261 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 262 | ! |
message("Initializing tm_g_pp_adverse_events")
|
| 263 | ! |
checkmate::assert_string(label) |
| 264 | ! |
checkmate::assert_string(dataname) |
| 265 | ! |
checkmate::assert_string(parentname) |
| 266 | ! |
checkmate::assert_string(patient_col) |
| 267 | ! |
checkmate::assert_class(aeterm, "choices_selected", null.ok = TRUE) |
| 268 | ! |
checkmate::assert_class(tox_grade, "choices_selected", null.ok = TRUE) |
| 269 | ! |
checkmate::assert_class(causality, "choices_selected", null.ok = TRUE) |
| 270 | ! |
checkmate::assert_class(outcome, "choices_selected", null.ok = TRUE) |
| 271 | ! |
checkmate::assert_class(action, "choices_selected", null.ok = TRUE) |
| 272 | ! |
checkmate::assert_class(time, "choices_selected", null.ok = TRUE) |
| 273 | ! |
checkmate::assert_class(decod, "choices_selected", null.ok = TRUE) |
| 274 | ! |
checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE) |
| 275 | ! |
checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
| 276 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 277 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 278 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 279 | ! |
checkmate::assert_numeric( |
| 280 | ! |
plot_width[1], |
| 281 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 282 |
) |
|
| 283 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 284 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 285 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 286 | ||
| 287 | ! |
args <- as.list(environment()) |
| 288 | ! |
data_extract_list <- list( |
| 289 | ! |
aeterm = `if`(is.null(aeterm), NULL, cs_to_des_select(aeterm, dataname = dataname)), |
| 290 | ! |
tox_grade = `if`(is.null(tox_grade), NULL, cs_to_des_select(tox_grade, dataname = dataname)), |
| 291 | ! |
causality = `if`(is.null(causality), NULL, cs_to_des_select(causality, dataname = dataname)), |
| 292 | ! |
outcome = `if`(is.null(outcome), NULL, cs_to_des_select(outcome, dataname = dataname)), |
| 293 | ! |
action = `if`(is.null(action), NULL, cs_to_des_select(action, dataname = dataname)), |
| 294 | ! |
time = `if`(is.null(time), NULL, cs_to_des_select(time, dataname = dataname)), |
| 295 | ! |
decod = `if`(is.null(decod), NULL, cs_to_des_select(decod, dataname = dataname)) |
| 296 |
) |
|
| 297 | ||
| 298 | ! |
module( |
| 299 | ! |
label = label, |
| 300 | ! |
ui = ui_g_adverse_events, |
| 301 | ! |
ui_args = c(data_extract_list, args), |
| 302 | ! |
server = srv_g_adverse_events, |
| 303 | ! |
server_args = c( |
| 304 | ! |
data_extract_list, |
| 305 | ! |
list( |
| 306 | ! |
dataname = dataname, |
| 307 | ! |
parentname = parentname, |
| 308 | ! |
label = label, |
| 309 | ! |
patient_col = patient_col, |
| 310 | ! |
plot_height = plot_height, |
| 311 | ! |
plot_width = plot_width, |
| 312 | ! |
ggplot2_args = ggplot2_args |
| 313 |
) |
|
| 314 |
), |
|
| 315 | ! |
datanames = c(dataname, parentname) |
| 316 |
) |
|
| 317 |
} |
|
| 318 | ||
| 319 |
#' @keywords internal |
|
| 320 |
ui_g_adverse_events <- function(id, ...) {
|
|
| 321 | ! |
ui_args <- list(...) |
| 322 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 323 | ! |
ui_args$aeterm, |
| 324 | ! |
ui_args$tox_grade, |
| 325 | ! |
ui_args$causality, |
| 326 | ! |
ui_args$outcome, |
| 327 | ! |
ui_args$action, |
| 328 | ! |
ui_args$time, |
| 329 | ! |
ui_args$decod |
| 330 |
) |
|
| 331 | ||
| 332 | ! |
ns <- NS(id) |
| 333 | ! |
teal.widgets::standard_layout( |
| 334 | ! |
output = tags$div( |
| 335 | ! |
htmlOutput(ns("title")),
|
| 336 | ! |
teal.widgets::get_dt_rows(ns("table"), ns("table_rows")),
|
| 337 | ! |
DT::DTOutput(outputId = ns("table")),
|
| 338 | ! |
teal.widgets::plot_with_settings_ui(id = ns("chart"))
|
| 339 |
), |
|
| 340 | ! |
encoding = tags$div( |
| 341 |
### Reporter |
|
| 342 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 343 |
### |
|
| 344 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 345 | ! |
teal.transform::datanames_input(ui_args[c( |
| 346 | ! |
"aeterm", "tox_grade", "causality", "outcome", |
| 347 | ! |
"action", "time", "decod" |
| 348 |
)]), |
|
| 349 | ! |
teal.widgets::optionalSelectInput( |
| 350 | ! |
ns("patient_id"),
|
| 351 | ! |
"Select Patient:", |
| 352 | ! |
multiple = FALSE, |
| 353 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 354 |
), |
|
| 355 | ! |
teal.transform::data_extract_ui( |
| 356 | ! |
id = ns("aeterm"),
|
| 357 | ! |
label = "Select AETERM variable:", |
| 358 | ! |
data_extract_spec = ui_args$aeterm, |
| 359 | ! |
is_single_dataset = is_single_dataset_value |
| 360 |
), |
|
| 361 | ! |
teal.transform::data_extract_ui( |
| 362 | ! |
id = ns("tox_grade"),
|
| 363 | ! |
label = "Select AETOXGR variable:", |
| 364 | ! |
data_extract_spec = ui_args$tox_grade, |
| 365 | ! |
is_single_dataset = is_single_dataset_value |
| 366 |
), |
|
| 367 | ! |
teal.transform::data_extract_ui( |
| 368 | ! |
id = ns("causality"),
|
| 369 | ! |
label = "Select AEREL variable:", |
| 370 | ! |
data_extract_spec = ui_args$causality, |
| 371 | ! |
is_single_dataset = is_single_dataset_value |
| 372 |
), |
|
| 373 | ! |
teal.transform::data_extract_ui( |
| 374 | ! |
id = ns("outcome"),
|
| 375 | ! |
label = "Select AEOUT variable:", |
| 376 | ! |
data_extract_spec = ui_args$outcome, |
| 377 | ! |
is_single_dataset = is_single_dataset_value |
| 378 |
), |
|
| 379 | ! |
teal.transform::data_extract_ui( |
| 380 | ! |
id = ns("action"),
|
| 381 | ! |
label = "Select AEACN variable:", |
| 382 | ! |
data_extract_spec = ui_args$action, |
| 383 | ! |
is_single_dataset = is_single_dataset_value |
| 384 |
), |
|
| 385 | ! |
teal.transform::data_extract_ui( |
| 386 | ! |
id = ns("time"),
|
| 387 | ! |
label = "Select ASTDY variable:", |
| 388 | ! |
data_extract_spec = ui_args$time, |
| 389 | ! |
is_single_dataset = is_single_dataset_value |
| 390 |
), |
|
| 391 | ! |
`if`( |
| 392 | ! |
is.null(ui_args$decod), |
| 393 | ! |
NULL, |
| 394 | ! |
teal.transform::data_extract_ui( |
| 395 | ! |
id = ns("decod"),
|
| 396 | ! |
label = "Select DECOD variable:", |
| 397 | ! |
data_extract_spec = ui_args$decod, |
| 398 | ! |
is_single_dataset = is_single_dataset_value |
| 399 |
) |
|
| 400 |
), |
|
| 401 | ! |
teal.widgets::panel_item( |
| 402 | ! |
title = "Plot settings", |
| 403 | ! |
collapsed = TRUE, |
| 404 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 405 | ! |
ns("font_size"),
|
| 406 | ! |
"Font Size", |
| 407 | ! |
ui_args$font_size, |
| 408 | ! |
ticks = FALSE, step = 1 |
| 409 |
) |
|
| 410 |
) |
|
| 411 |
), |
|
| 412 | ! |
forms = tagList( |
| 413 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 414 |
), |
|
| 415 | ! |
pre_output = ui_args$pre_output, |
| 416 | ! |
post_output = ui_args$post_output |
| 417 |
) |
|
| 418 |
} |
|
| 419 | ||
| 420 |
#' @keywords internal |
|
| 421 |
srv_g_adverse_events <- function(id, |
|
| 422 |
data, |
|
| 423 |
filter_panel_api, |
|
| 424 |
reporter, |
|
| 425 |
dataname, |
|
| 426 |
parentname, |
|
| 427 |
patient_col, |
|
| 428 |
aeterm, |
|
| 429 |
tox_grade, |
|
| 430 |
causality, |
|
| 431 |
outcome, |
|
| 432 |
action, |
|
| 433 |
time, |
|
| 434 |
decod, |
|
| 435 |
plot_height, |
|
| 436 |
plot_width, |
|
| 437 |
label, |
|
| 438 |
ggplot2_args) {
|
|
| 439 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 440 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 441 | ! |
checkmate::assert_class(data, "reactive") |
| 442 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 443 | ||
| 444 | ! |
moduleServer(id, function(input, output, session) {
|
| 445 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 446 | ! |
patient_id <- reactive(input$patient_id) |
| 447 | ||
| 448 |
# Init |
|
| 449 | ! |
patient_data_base <- reactive(unique(data()[[parentname]][[patient_col]])) |
| 450 | ! |
teal.widgets::updateOptionalSelectInput( |
| 451 | ! |
session, |
| 452 | ! |
"patient_id", |
| 453 | ! |
choices = patient_data_base(), |
| 454 | ! |
selected = patient_data_base()[1] |
| 455 |
) |
|
| 456 | ||
| 457 | ! |
observeEvent(patient_data_base(), |
| 458 | ! |
handlerExpr = {
|
| 459 | ! |
teal.widgets::updateOptionalSelectInput( |
| 460 | ! |
session, |
| 461 | ! |
"patient_id", |
| 462 | ! |
choices = patient_data_base(), |
| 463 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 464 | ! |
patient_data_base() |
| 465 |
} else {
|
|
| 466 | ! |
intersect(patient_id(), patient_data_base()) |
| 467 |
} |
|
| 468 |
) |
|
| 469 |
}, |
|
| 470 | ! |
ignoreInit = TRUE |
| 471 |
) |
|
| 472 | ||
| 473 |
# Adverse events tab ---- |
|
| 474 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 475 | ! |
data_extract = Filter( |
| 476 | ! |
Negate(is.null), |
| 477 | ! |
list( |
| 478 | ! |
aeterm = aeterm, |
| 479 | ! |
tox_grade = tox_grade, |
| 480 | ! |
causality = causality, |
| 481 | ! |
outcome = outcome, |
| 482 | ! |
action = action, |
| 483 | ! |
time = time, |
| 484 | ! |
decod = decod |
| 485 |
) |
|
| 486 |
), |
|
| 487 | ! |
datasets = data, |
| 488 | ! |
select_validation_rule = list( |
| 489 | ! |
aeterm = shinyvalidate::sv_required("Please select AETERM variable."),
|
| 490 | ! |
tox_grade = shinyvalidate::sv_required("Please select AETOXGR variable."),
|
| 491 | ! |
causality = shinyvalidate::sv_required("Please select AEREL variable."),
|
| 492 | ! |
outcome = shinyvalidate::sv_required("Please select AEOUT variable."),
|
| 493 | ! |
action = shinyvalidate::sv_required("Please select AEACN variable."),
|
| 494 | ! |
time = shinyvalidate::sv_required("Please select ASTDY variable."),
|
| 495 | ! |
decod = shinyvalidate::sv_required("Please select ANRIND variable.")
|
| 496 |
) |
|
| 497 |
) |
|
| 498 | ||
| 499 | ! |
iv_r <- reactive({
|
| 500 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 501 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient"))
|
| 502 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 503 |
}) |
|
| 504 | ||
| 505 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 506 | ! |
datasets = data, |
| 507 | ! |
selector_list = selector_list |
| 508 |
) |
|
| 509 | ||
| 510 | ! |
anl_q <- reactive( |
| 511 | ! |
data() %>% |
| 512 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 513 |
) |
|
| 514 | ||
| 515 | ! |
all_q <- reactive({
|
| 516 | ! |
teal::validate_inputs(iv_r()) |
| 517 | ! |
anl_m <- anl_inputs() |
| 518 | ||
| 519 | ! |
ANL <- anl_q()[["ANL"]] |
| 520 | ||
| 521 | ! |
teal::validate_has_data(ANL[ANL[[patient_col]] == input$patient_id, ], min_nrow = 1) |
| 522 | ||
| 523 | ! |
anl_q2 <- teal.code::eval_code( |
| 524 | ! |
anl_q(), |
| 525 | ! |
substitute( |
| 526 | ! |
expr = {
|
| 527 | ! |
pt_id <- patient_id |
| 528 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 529 | ! |
}, env = list( |
| 530 | ! |
patient_col = patient_col, |
| 531 | ! |
patient_id = patient_id() |
| 532 |
) |
|
| 533 |
) |
|
| 534 |
) |
|
| 535 | ||
| 536 | ! |
calls <- template_adverse_events( |
| 537 | ! |
dataname = "ANL", |
| 538 | ! |
aeterm = input[[extract_input("aeterm", dataname)]],
|
| 539 | ! |
tox_grade = input[[extract_input("tox_grade", dataname)]],
|
| 540 | ! |
causality = input[[extract_input("causality", dataname)]],
|
| 541 | ! |
outcome = input[[extract_input("outcome", dataname)]],
|
| 542 | ! |
action = input[[extract_input("action", dataname)]],
|
| 543 | ! |
time = input[[extract_input("time", dataname)]],
|
| 544 | ! |
decod = input[[extract_input("decod", dataname)]],
|
| 545 | ! |
patient_id = patient_id(), |
| 546 | ! |
font_size = input[["font_size"]], |
| 547 | ! |
ggplot2_args = ggplot2_args |
| 548 |
) |
|
| 549 | ||
| 550 | ! |
teal.code::eval_code(anl_q2, as.expression(calls)) |
| 551 |
}) |
|
| 552 | ||
| 553 | ! |
output$title <- renderText({
|
| 554 | ! |
paste("<h5><b>Patient ID:", all_q()[["pt_id"]], "</b></h5>")
|
| 555 |
}) |
|
| 556 | ||
| 557 | ! |
output$table <- DT::renderDataTable( |
| 558 | ! |
expr = teal.code::dev_suppress(all_q()[["table"]]), |
| 559 | ! |
options = list(pageLength = input$table_rows) |
| 560 |
) |
|
| 561 | ||
| 562 | ! |
plot_r <- reactive({
|
| 563 | ! |
req(iv_r()$is_valid()) |
| 564 | ! |
all_q()[["plot"]] |
| 565 |
}) |
|
| 566 | ||
| 567 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 568 | ! |
id = "chart", |
| 569 | ! |
plot_r = plot_r, |
| 570 | ! |
height = plot_height, |
| 571 | ! |
width = plot_width |
| 572 |
) |
|
| 573 | ||
| 574 | ! |
teal.widgets::verbatim_popup_srv( |
| 575 | ! |
id = "rcode", |
| 576 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 577 | ! |
title = label |
| 578 |
) |
|
| 579 | ||
| 580 |
### REPORTER |
|
| 581 | ! |
if (with_reporter) {
|
| 582 | ! |
card_fun <- function(comment, label) {
|
| 583 | ! |
card <- teal::report_card_template( |
| 584 | ! |
title = "Patient Profile Adverse Events Plot", |
| 585 | ! |
label = label, |
| 586 | ! |
with_filter = with_filter, |
| 587 | ! |
filter_panel_api = filter_panel_api |
| 588 |
) |
|
| 589 | ! |
card$append_text("Table", "header3")
|
| 590 | ! |
card$append_table(teal.code::dev_suppress(all_q()[["table"]])) |
| 591 | ! |
card$append_text("Plot", "header3")
|
| 592 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 593 | ! |
if (!comment == "") {
|
| 594 | ! |
card$append_text("Comment", "header3")
|
| 595 | ! |
card$append_text(comment) |
| 596 |
} |
|
| 597 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 598 | ! |
card |
| 599 |
} |
|
| 600 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 601 |
} |
|
| 602 |
### |
|
| 603 |
}) |
|
| 604 |
} |
| 1 |
#' Observer for Treatment reference variable |
|
| 2 |
#' |
|
| 3 |
#' @description `r lifecycle::badge("stable")`
|
|
| 4 |
#' Updates the reference and comparison Treatments when the selected Treatment variable changes |
|
| 5 |
#' |
|
| 6 |
#' @param session (`environment`)\cr shiny session |
|
| 7 |
#' @param input (`character`)\cr shiny input |
|
| 8 |
#' @param output (`character`)\cr shiny input |
|
| 9 |
#' @param id_ref (`character`)\cr id of reference Treatment input UI element |
|
| 10 |
#' @param id_comp (`character`)\cr id of comparison group input UI element |
|
| 11 |
#' @param id_arm_var (`character`)\cr id of Treatment variable input UI element |
|
| 12 |
#' @param data (`reactive` or `data.frame`)\cr dataset used to validate Treatment reference inputs and |
|
| 13 |
#' set `id_ref` input. |
|
| 14 |
#' @param arm_ref_comp (`unknown`)\cr Treatment reference and compare variables provided as a |
|
| 15 |
#' nested list where each Treatment variable corresponds a list specifying the default levels for the |
|
| 16 |
#' reference and comparison treatments. |
|
| 17 |
#' @param module (`character`)\cr name of the module where this is called (this is only used |
|
| 18 |
#' to produce more informative error messages) |
|
| 19 |
#' @param on_off (`logical`)\cr A reactive that can be used to |
|
| 20 |
#' stop the whole observer if `FALSE`. |
|
| 21 |
#' @param input_id (`character`)\cr unique id that the buckets will be referenced with. |
|
| 22 |
#' @param output_id (`character`)\cr name of the UI id that the output will be written to. |
|
| 23 |
#' @return Returns a `shinyvalidate::InputValidator` which checks that there is at least one reference |
|
| 24 |
#' and comparison arm |
|
| 25 |
#' @keywords internal |
|
| 26 |
#' |
|
| 27 |
arm_ref_comp_observer <- function(session, |
|
| 28 |
input, |
|
| 29 |
output, |
|
| 30 |
id_ref = "Ref", |
|
| 31 |
id_comp = "Comp", |
|
| 32 |
id_arm_var, |
|
| 33 |
data, |
|
| 34 |
arm_ref_comp, |
|
| 35 |
module, |
|
| 36 |
on_off = reactive(TRUE), |
|
| 37 |
input_id = "buckets", |
|
| 38 |
output_id = "arms_buckets") {
|
|
| 39 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 40 | ! |
iv1 <- shinyvalidate::InputValidator$new() |
| 41 | ! |
iv2 <- shinyvalidate::InputValidator$new() |
| 42 | ! |
iv2$condition(~ iv1$is_valid()) |
| 43 | ! |
iv1$add_rule(id_arm_var, shinyvalidate::sv_required("Treatment variable must be selected"))
|
| 44 | ! |
iv2$add_rule(input_id, ~ if (length(.[[id_ref]]) == 0) "A reference arm must be selected") |
| 45 | ! |
iv2$add_rule(input_id, ~ if (length(.[[id_comp]]) == 0) "A comparison arm must be selected") |
| 46 | ! |
iv$add_validator(iv1) |
| 47 | ! |
iv$add_validator(iv2) |
| 48 | ||
| 49 | ||
| 50 | ! |
output[[output_id]] <- renderUI({
|
| 51 | ! |
if (isTRUE(on_off())) {
|
| 52 | ! |
df <- if (is.reactive(data)) {
|
| 53 | ! |
data() |
| 54 |
} else {
|
|
| 55 | ! |
data |
| 56 |
} |
|
| 57 | ! |
check_arm_ref_comp(arm_ref_comp, df, module) ## throws an error if there are issues |
| 58 | ||
| 59 | ! |
arm_var <- req(input[[id_arm_var]]) |
| 60 | ||
| 61 | ! |
arm <- df[[arm_var]] |
| 62 | ! |
teal::validate_has_elements(arm, "Treatment variable is empty.") |
| 63 | ||
| 64 | ! |
arm_levels <- if (is.factor(arm)) {
|
| 65 | ! |
levels(droplevels(arm)) |
| 66 |
} else {
|
|
| 67 | ! |
unique(arm) |
| 68 |
} |
|
| 69 | ! |
default_settings <- arm_ref_comp[[arm_var]] |
| 70 | ||
| 71 | ! |
if (is.null(default_settings)) {
|
| 72 | ! |
ref_arm <- arm_levels[1] |
| 73 | ! |
comp_arm <- setdiff(arm_levels, ref_arm) |
| 74 |
} else {
|
|
| 75 | ! |
ref_arm <- default_settings$ref |
| 76 | ! |
comp_arm <- default_settings$comp |
| 77 |
} |
|
| 78 | ||
| 79 | ! |
buckets <- list(ref_arm, comp_arm) |
| 80 | ! |
names(buckets) <- c(id_ref, id_comp) |
| 81 | ||
| 82 | ! |
teal.widgets::draggable_buckets( |
| 83 | ! |
session$ns(input_id), |
| 84 | ! |
label = "Groups", |
| 85 | ! |
elements = character(), |
| 86 | ! |
buckets = buckets |
| 87 |
) |
|
| 88 |
} |
|
| 89 |
}) |
|
| 90 | ||
| 91 | ! |
return(iv) |
| 92 |
} |
|
| 93 | ||
| 94 |
#' Check if the Treatment variable is reference or compare |
|
| 95 |
#' |
|
| 96 |
#' @description `r lifecycle::badge("stable")`
|
|
| 97 |
#' @param x (`character`)\cr Name of the variable |
|
| 98 |
#' @param df_to_check (`data.frame`)\cr table to check |
|
| 99 |
#' @param module (`character`)\cr teal module the ref and comp are called in |
|
| 100 |
#' |
|
| 101 |
#' @keywords internal |
|
| 102 |
#' |
|
| 103 |
#' @return `TRUE` or `FALSE` whether the variable is in ref or comp |
|
| 104 |
check_arm_ref_comp <- function(x, df_to_check, module) {
|
|
| 105 | ! |
msg <- paste("module", module, "argument arm_ref_comp ")
|
| 106 | ||
| 107 | ! |
if (!is.null(x)) {
|
| 108 | ! |
if (!is.list(x)) {
|
| 109 | ! |
stop(msg, "needs to be a list or NULL") |
| 110 |
} |
|
| 111 | ||
| 112 | ! |
vars <- names(x) |
| 113 | ! |
if (is.null(vars) || any(vars == "")) {
|
| 114 | ! |
stop(msg, "is not named") |
| 115 |
} |
|
| 116 | ||
| 117 | ! |
if (!all(vars %in% names(df_to_check))) {
|
| 118 | ! |
stop(msg, "refers to variables that are not in the data") |
| 119 |
} |
|
| 120 | ||
| 121 | ! |
Map( |
| 122 | ! |
x, vars, |
| 123 | ! |
f = function(xi, var) {
|
| 124 | ! |
if (!checkmate::check_list(xi) || !setequal(names(xi), c("comp", "ref"))) {
|
| 125 | ! |
stop( |
| 126 | ! |
msg, "definition for Treatment variable ", |
| 127 | ! |
var, " list element needs to be lists with ref and comp elements" |
| 128 |
) |
|
| 129 |
} |
|
| 130 |
} |
|
| 131 |
) |
|
| 132 |
} |
|
| 133 | ||
| 134 | ! |
invisible(TRUE) |
| 135 |
} |
| 1 |
#' Template: Patient Profile Timeline Plot |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a patient profile timeline [ggplot2::ggplot()] plot using ADaM datasets. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_adverse_events |
|
| 6 |
#' @inheritParams template_arguments |
|
| 7 |
#' @param aetime_start (`character`)\cr name of start date/time of adverse event variable. |
|
| 8 |
#' @param aetime_end (`character`)\cr name of end date/time of adverse event variable. |
|
| 9 |
#' @param dstime_start (`character`)\cr name of date/time of first exposure to treatment variable. |
|
| 10 |
#' @param dstime_end (`character`)\cr name of date/time of last exposure to treatment variable. |
|
| 11 |
#' @param aerelday_start (`character`)\cr name of adverse event study start day variable. |
|
| 12 |
#' @param aerelday_end (`character`)\cr name of adverse event study end day variable. |
|
| 13 |
#' @param dsrelday_start (`character`)\cr name of concomitant medications study start day variable. |
|
| 14 |
#' @param dsrelday_end (`character`)\cr name of concomitant medications study day start variable. |
|
| 15 |
#' @param relative_day (`logical`)\cr whether to use relative days (`TRUE`) or absolute dates (`FALSE`). |
|
| 16 |
#' |
|
| 17 |
#' @inherit template_arguments return |
|
| 18 |
#' |
|
| 19 |
#' @seealso [tm_g_pp_patient_timeline()] |
|
| 20 |
#' |
|
| 21 |
#' @keywords internal |
|
| 22 |
template_patient_timeline <- function(dataname = "ANL", |
|
| 23 |
aeterm = "AETERM", |
|
| 24 |
aetime_start = "ASTDTM", |
|
| 25 |
aetime_end = "AENDTM", |
|
| 26 |
dstime_start = "CMASTDTM", |
|
| 27 |
dstime_end = "CMAENDTM", |
|
| 28 |
cmdecod = "CMDECOD", |
|
| 29 |
aerelday_start = NULL, |
|
| 30 |
aerelday_end = NULL, |
|
| 31 |
dsrelday_start = NULL, |
|
| 32 |
dsrelday_end = NULL, |
|
| 33 |
relative_day = FALSE, |
|
| 34 |
patient_id, |
|
| 35 |
font_size = 12L, |
|
| 36 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 37 |
# Note: The variables used for aetime_start, aetime_end, dstime_start and dstime_end are to be |
|
| 38 |
# updated after random.cdisc.data updates. |
|
| 39 | ||
| 40 | ! |
checkmate::assert_string(dataname) |
| 41 | ! |
checkmate::assert_string(aeterm, null.ok = TRUE) |
| 42 | ! |
checkmate::assert_string(aetime_start, null.ok = TRUE) |
| 43 | ! |
checkmate::assert_string(aetime_end, null.ok = TRUE) |
| 44 | ! |
checkmate::assert_string(dstime_start, null.ok = TRUE) |
| 45 | ! |
checkmate::assert_string(dstime_end, null.ok = TRUE) |
| 46 | ! |
checkmate::assert_string(cmdecod, null.ok = TRUE) |
| 47 | ! |
checkmate::assert_string(aerelday_start, null.ok = TRUE) |
| 48 | ! |
checkmate::assert_string(dsrelday_start, null.ok = TRUE) |
| 49 | ! |
checkmate::assert_number(font_size) |
| 50 | ! |
checkmate::assert_flag(relative_day) |
| 51 | ! |
checkmate::assert_string(patient_id) |
| 52 | ||
| 53 | ! |
chart_list <- list() |
| 54 | ! |
if (!relative_day) {
|
| 55 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 56 | ! |
teal.widgets::resolve_ggplot2_args( |
| 57 | ! |
user_plot = ggplot2_args, |
| 58 | ! |
module_plot = teal.widgets::ggplot2_args( |
| 59 | ! |
labs = list(title = paste0("Patient ID: ", patient_id), x = "Absolute Study Dates"),
|
| 60 | ! |
theme = list( |
| 61 | ! |
plot.title = substitute( |
| 62 | ! |
ggplot2::element_text(hjust = 0, size = font_size_var), |
| 63 | ! |
list(font_size_var = font_size) |
| 64 |
), |
|
| 65 | ! |
axis.text = substitute( |
| 66 | ! |
ggplot2::element_text(size = font_size_var, face = "bold", colour = "black"), |
| 67 | ! |
list(font_size_var = font_size) |
| 68 |
), |
|
| 69 | ! |
axis.title = substitute( |
| 70 | ! |
ggplot2::element_text(size = font_size_var, face = "bold", colour = "black"), |
| 71 | ! |
list(font_size_var = font_size) |
| 72 |
), |
|
| 73 | ! |
text = substitute(ggplot2::element_text(size = font_size_var), list(font_size_var = font_size)) |
| 74 |
) |
|
| 75 |
) |
|
| 76 |
) |
|
| 77 |
) |
|
| 78 | ||
| 79 | ! |
chart_list <- add_expr( |
| 80 | ! |
chart_list, |
| 81 | ! |
new_expr = quote({
|
| 82 | ! |
posixct_origin <- "1970-01-01 00:00.00 UTC" |
| 83 | ! |
med_chart <- NULL |
| 84 | ! |
ae_chart <- NULL |
| 85 |
}) |
|
| 86 |
) |
|
| 87 | ||
| 88 | ! |
if (all(vapply(list(cmdecod, dstime_start, dstime_end), Negate(is.null), logical(1)))) {
|
| 89 | ! |
chart_list <- add_expr( |
| 90 | ! |
chart_list, |
| 91 | ! |
substitute( |
| 92 | ! |
expr = {
|
| 93 | ! |
med_chart <- dataname %>% |
| 94 | ! |
dplyr::select(dstime_start, dstime_end, cmdecod) %>% |
| 95 | ! |
dplyr::distinct() |
| 96 | ||
| 97 | ! |
colnames(med_chart) <- c("start", "end", "event")
|
| 98 | ! |
med_chart$group <- "Medication" |
| 99 |
}, |
|
| 100 | ! |
env = list( |
| 101 | ! |
dataname = as.name(dataname), |
| 102 | ! |
dstime_start = `if`(length(dstime_start), as.name(dstime_start), dstime_start), |
| 103 | ! |
dstime_end = `if`(length(dstime_end), as.name(dstime_end), dstime_end), |
| 104 | ! |
cmdecod = `if`(length(cmdecod), as.name(cmdecod), cmdecod) |
| 105 |
) |
|
| 106 |
) |
|
| 107 |
) |
|
| 108 |
} |
|
| 109 | ||
| 110 | ! |
if (all(vapply(list(aeterm, aetime_start, aetime_end), Negate(is.null), logical(1)))) {
|
| 111 | ! |
chart_list <- add_expr( |
| 112 | ! |
chart_list, |
| 113 | ! |
substitute( |
| 114 | ! |
expr = {
|
| 115 | ! |
ae_chart <- dataname %>% |
| 116 | ! |
dplyr::select(aetime_start, aetime_end, aeterm) %>% |
| 117 | ! |
dplyr::distinct() |
| 118 | ! |
colnames(ae_chart) <- c("start", "end", "event")
|
| 119 | ! |
ae_chart$group <- "Adverse Events" |
| 120 |
}, |
|
| 121 | ! |
env = list( |
| 122 | ! |
dataname = as.name(dataname), |
| 123 | ! |
aeterm = `if`(length(aeterm), as.name(aeterm), aeterm), |
| 124 | ! |
aetime_start = `if`(length(aetime_start), as.name(aetime_start), aetime_start), |
| 125 | ! |
aetime_end = `if`(length(aetime_end), as.name(aetime_end), aetime_end) |
| 126 |
) |
|
| 127 |
) |
|
| 128 |
) |
|
| 129 |
} |
|
| 130 | ||
| 131 | ! |
chart_list <- add_expr( |
| 132 | ! |
chart_list, |
| 133 | ! |
substitute( |
| 134 | ! |
expr = {
|
| 135 | ! |
vistime_data <- dplyr::bind_rows(list(ae_chart, med_chart)) |
| 136 |
# in some cases, dates are converted to numeric so this is a step to convert them back |
|
| 137 | ! |
vistime_data$start <- as.POSIXct(vistime_data$start, origin = posixct_origin) |
| 138 | ! |
vistime_data$end <- as.POSIXct(vistime_data$end, origin = posixct_origin) |
| 139 | ! |
vistime_data <- vistime_data %>% |
| 140 | ! |
dplyr::filter(stats::complete.cases(.[, c("start", "end", "event")])) %>%
|
| 141 | ! |
dplyr::filter(!is.na(format(.data$start))) %>% |
| 142 | ! |
dplyr::filter(!is.na(format(.data$end))) |
| 143 | ||
| 144 | ! |
if (nrow(vistime_data) == 0 || all(is.na(format(c(vistime_data$start, vistime_data$end))))) {
|
| 145 | ! |
empty_plot_label <- "Empty Plot (either due to filtering or missing values).\n Consider relaxing filters." |
| 146 | ! |
df <- data.frame( |
| 147 | ! |
x = 0, |
| 148 | ! |
y = 0, |
| 149 | ! |
label = empty_plot_label |
| 150 |
) |
|
| 151 | ! |
patient_timeline_plot <- ggplot2::ggplot( |
| 152 | ! |
data = df, |
| 153 | ! |
ggplot2::aes( |
| 154 | ! |
x = x, |
| 155 | ! |
y = y, |
| 156 | ! |
label = label |
| 157 |
) |
|
| 158 |
) + |
|
| 159 | ! |
ggplot2::geom_label() + |
| 160 | ! |
ggplot2::theme_void() |
| 161 |
} else {
|
|
| 162 | ! |
patient_timeline_plot <- vistime::gg_vistime( |
| 163 | ! |
vistime_data, |
| 164 | ! |
col.event = "event", |
| 165 | ! |
col.group = "group", |
| 166 | ! |
show_labels = FALSE |
| 167 |
) + |
|
| 168 | ! |
ggrepel::geom_text_repel( |
| 169 | ! |
mapping = ggplot2::aes(label = event), |
| 170 | ! |
size = font_size_var / 3.5, |
| 171 | ! |
color = "black", |
| 172 | ! |
direction = "x", |
| 173 | ! |
nudge_x = 0.5, |
| 174 | ! |
segment.size = 0.1 |
| 175 |
) + |
|
| 176 | ! |
ggplot2::scale_x_datetime(labels = scales::date_format("%b-%Y")) + labs + themes
|
| 177 |
} |
|
| 178 | ! |
patient_timeline_plot |
| 179 |
}, |
|
| 180 | ! |
env = list( |
| 181 | ! |
font_size_var = font_size, |
| 182 | ! |
labs = parsed_ggplot2_args$labs, |
| 183 | ! |
themes = parsed_ggplot2_args$theme |
| 184 |
) |
|
| 185 |
) |
|
| 186 |
) |
|
| 187 |
} else {
|
|
| 188 | ! |
parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( |
| 189 | ! |
teal.widgets::resolve_ggplot2_args( |
| 190 | ! |
user_plot = ggplot2_args, |
| 191 | ! |
module_plot = teal.widgets::ggplot2_args( |
| 192 | ! |
labs = list(title = paste0("Patient ID: ", patient_id), x = "Relative Study Days", y = ""),
|
| 193 | ! |
theme = list( |
| 194 | ! |
plot.title = substitute( |
| 195 | ! |
ggplot2::element_text(hjust = 0, size = font_size_var), |
| 196 | ! |
list(font_size_var = font_size) |
| 197 |
), |
|
| 198 | ! |
axis.text = substitute( |
| 199 | ! |
ggplot2::element_text(size = font_size_var, face = "bold", colour = "black"), |
| 200 | ! |
list(font_size_var = font_size) |
| 201 |
), |
|
| 202 | ! |
axis.title = substitute( |
| 203 | ! |
ggplot2::element_text(size = font_size_var, face = "bold", colour = "black"), |
| 204 | ! |
list(font_size_var = font_size) |
| 205 |
), |
|
| 206 | ! |
text = substitute(ggplot2::element_text(size = font_size_var), list(font_size_var = font_size)), |
| 207 | ! |
legend.position = "none" |
| 208 |
) |
|
| 209 |
) |
|
| 210 |
), |
|
| 211 | ! |
ggtheme = "classic" |
| 212 |
) |
|
| 213 | ||
| 214 | ! |
chart_list <- add_expr( |
| 215 | ! |
chart_list, |
| 216 | ! |
new_expr = quote({
|
| 217 | ! |
med_chart <- NULL |
| 218 | ! |
ae_chart <- NULL |
| 219 |
}) |
|
| 220 |
) |
|
| 221 | ||
| 222 | ! |
if (length(c(dsrelday_start, dsrelday_end, cmdecod)) == 3) {
|
| 223 | ! |
chart_list <- add_expr( |
| 224 | ! |
chart_list, |
| 225 | ! |
substitute( |
| 226 | ! |
expr = {
|
| 227 | ! |
med_chart <- dataname %>% |
| 228 | ! |
dplyr::select(dsrelday_start_var, dsrelday_end_var, cmdecod) %>% |
| 229 | ! |
dplyr::distinct() %>% |
| 230 | ! |
dplyr::rename(start = dsrelday_start_var, end = dsrelday_end_var, event = cmdecod) %>% |
| 231 | ! |
dplyr::mutate(group = "Medication") |
| 232 |
}, |
|
| 233 | ! |
env = list( |
| 234 | ! |
dataname = as.name(dataname), |
| 235 | ! |
cmdecod = cmdecod, |
| 236 | ! |
dsrelday_start_var = dsrelday_start, |
| 237 | ! |
dsrelday_end_var = dsrelday_end |
| 238 |
) |
|
| 239 |
) |
|
| 240 |
) |
|
| 241 |
} |
|
| 242 | ||
| 243 | ! |
if (length(c(aerelday_start, aerelday_end, aeterm)) == 3) {
|
| 244 | ! |
chart_list <- add_expr( |
| 245 | ! |
chart_list, |
| 246 | ! |
substitute( |
| 247 | ! |
expr = {
|
| 248 | ! |
ae_chart <- dataname %>% |
| 249 | ! |
dplyr::select(aerelday_start_var, aerelday_end_var, aeterm) %>% |
| 250 | ! |
dplyr::distinct() %>% |
| 251 | ! |
dplyr::rename(start = aerelday_start_var, end = aerelday_end_var, event = aeterm) %>% |
| 252 | ! |
dplyr::mutate(group = "Adverse Events") |
| 253 |
}, |
|
| 254 | ! |
env = list( |
| 255 | ! |
dataname = as.name(dataname), |
| 256 | ! |
aeterm = aeterm, |
| 257 | ! |
aerelday_start_var = aerelday_start, |
| 258 | ! |
aerelday_end_var = aerelday_end |
| 259 |
) |
|
| 260 |
) |
|
| 261 |
) |
|
| 262 |
} |
|
| 263 | ||
| 264 | ! |
chart_list <- add_expr( |
| 265 | ! |
chart_list, |
| 266 | ! |
substitute( |
| 267 | ! |
expr = {
|
| 268 | ! |
vistime_data <- dplyr::bind_rows(list(ae_chart, med_chart)) |
| 269 | ! |
vistime_data <- vistime_data %>% |
| 270 | ! |
dplyr::filter(stats::complete.cases(.[, c("start", "end", "event")])) %>%
|
| 271 | ! |
dplyr::filter(!is.na(format(.data$start))) %>% |
| 272 | ! |
dplyr::filter(!is.na(format(.data$end))) %>% |
| 273 | ! |
dplyr::mutate(color = make.unique(group)) |
| 274 | ||
| 275 | ! |
if (nrow(vistime_data) == 0 || all(is.na(format(c(vistime_data$start, vistime_data$end))))) {
|
| 276 | ! |
empty_plot_label <- "Empty Plot (either due to filtering or missing values).\n Consider relaxing filters." |
| 277 | ! |
df <- data.frame( |
| 278 | ! |
x = 0, |
| 279 | ! |
y = 0, |
| 280 | ! |
label = empty_plot_label |
| 281 |
) |
|
| 282 | ! |
patient_timeline_plot <- ggplot2::ggplot( |
| 283 | ! |
data = df, |
| 284 | ! |
ggplot2::aes( |
| 285 | ! |
x = x, |
| 286 | ! |
y = y, |
| 287 | ! |
label = label |
| 288 |
) |
|
| 289 |
) + |
|
| 290 | ! |
ggplot2::geom_label() + |
| 291 | ! |
ggplot2::theme_void() |
| 292 |
} else {
|
|
| 293 | ! |
vistime_data$event <- factor(vistime_data$event, levels = rev(unique(vistime_data$event))) |
| 294 | ! |
vistime_data$group <- factor(vistime_data$group, levels = unique(vistime_data$group)) |
| 295 | ! |
patient_timeline_plot <- ggplot2::ggplot( |
| 296 | ! |
vistime_data, |
| 297 | ! |
ggplot2::aes(x = start, y = event, xend = end, yend = event, color = color) |
| 298 |
) + |
|
| 299 | ! |
ggplot2::geom_segment(size = 4) + |
| 300 | ! |
ggplot2::facet_grid(group ~ ., scales = "free", space = "free") + |
| 301 | ! |
ggplot2::scale_x_continuous(breaks = scales::pretty_breaks()) + |
| 302 | ! |
labs + |
| 303 | ! |
ggthemes + |
| 304 | ! |
themes |
| 305 |
} |
|
| 306 | ! |
patient_timeline_plot |
| 307 |
}, |
|
| 308 | ! |
env = list( |
| 309 | ! |
labs = parsed_ggplot2_args$labs, |
| 310 | ! |
ggthemes = parsed_ggplot2_args$ggtheme, |
| 311 | ! |
themes = parsed_ggplot2_args$theme |
| 312 |
) |
|
| 313 |
) |
|
| 314 |
) |
|
| 315 |
} |
|
| 316 | ||
| 317 | ! |
chart_list |
| 318 |
} |
|
| 319 | ||
| 320 |
#' teal Module: Patient Profile Timeline Plot |
|
| 321 |
#' |
|
| 322 |
#' This module produces a patient profile timeline [ggplot2::ggplot()] type plot using ADaM datasets. |
|
| 323 |
#' |
|
| 324 |
#' @inheritParams tm_g_pp_adverse_events |
|
| 325 |
#' @inheritParams module_arguments |
|
| 326 |
#' @inheritParams template_patient_timeline |
|
| 327 |
#' @param dataname_adcm (`character`)\cr name of `ADCM` dataset or equivalent. |
|
| 328 |
#' @param dataname_adae (`character`)\cr name of `ADAE` dataset or equivalent. |
|
| 329 |
#' @param aerelday_start ([teal.transform::choices_selected()])\cr object |
|
| 330 |
#' with all available choices and preselected option for the `ASTDY` variable from `dataname_adae`. |
|
| 331 |
#' @param aerelday_end ([teal.transform::choices_selected()])\cr object |
|
| 332 |
#' with all available choices and preselected option for the `AENDY` variable from `dataname_adae`. |
|
| 333 |
#' @param dsrelday_start ([teal.transform::choices_selected()])\cr object |
|
| 334 |
#' with all available choices and preselected option for the `ASTDY` variable from `dataname_adcm`. |
|
| 335 |
#' @param dsrelday_end ([teal.transform::choices_selected()])\cr object |
|
| 336 |
#' with all available choices and preselected option for the `AENDY` variable from `dataname_adcm`. |
|
| 337 |
#' @param cmdecod ([teal.transform::choices_selected()])\cr object with all |
|
| 338 |
#' available choices and preselected option for the `CMDECOD` variable from `dataname_adcm`. |
|
| 339 |
#' @param aetime_start ([teal.transform::choices_selected()])\cr object with |
|
| 340 |
#' all available choices and preselected option for the `ASTDTM` variable from `dataname_adae`. |
|
| 341 |
#' @param aetime_end ([teal.transform::choices_selected()])\cr object with all |
|
| 342 |
#' available choices and preselected option for the `AENDTM` variable from `dataname_adae`. |
|
| 343 |
#' @param dstime_start ([teal.transform::choices_selected()])\cr object with |
|
| 344 |
#' all available choices and preselected option for the `CMASTDTM` variable from `dataname_adcm`. |
|
| 345 |
#' @param dstime_end ([teal.transform::choices_selected()])\cr object with all |
|
| 346 |
#' available choices and preselected option for the `CMAENDTM` variable from `dataname_adcm`. |
|
| 347 |
#' |
|
| 348 |
#' @inherit module_arguments return |
|
| 349 |
#' |
|
| 350 |
#' @examples |
|
| 351 |
#' library(nestcolor) |
|
| 352 |
#' library(dplyr) |
|
| 353 |
#' |
|
| 354 |
#' data <- teal_data() |
|
| 355 |
#' data <- within(data, {
|
|
| 356 |
#' ADAE <- tmc_ex_adae |
|
| 357 |
#' ADSL <- tmc_ex_adsl %>% filter(USUBJID %in% ADAE$USUBJID) |
|
| 358 |
#' ADCM <- tmc_ex_adcm %>% mutate( |
|
| 359 |
#' CMSTDY = case_when( |
|
| 360 |
#' CMCAT == "medcl B" ~ 20, |
|
| 361 |
#' CMCAT == "medcl C" ~ 150, |
|
| 362 |
#' TRUE ~ 1 |
|
| 363 |
#' ) %>% with_label("Study Day of Start of Medication"),
|
|
| 364 |
#' CMENDY = case_when( |
|
| 365 |
#' CMCAT == "medcl B" ~ 700, |
|
| 366 |
#' CMCAT == "medcl C" ~ 1000, |
|
| 367 |
#' TRUE ~ 500 |
|
| 368 |
#' ) %>% with_label("Study Day of End of Medication"),
|
|
| 369 |
#' CMASTDTM = ASTDTM, |
|
| 370 |
#' CMAENDTM = AENDTM |
|
| 371 |
#' ) |
|
| 372 |
#' }) |
|
| 373 |
#' |
|
| 374 |
#' adcm_keys <- c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "ATC1", "ATC2", "ATC3", "ATC4")
|
|
| 375 |
#' datanames(data) <- c("ADSL", "ADAE", "ADCM")
|
|
| 376 |
#' join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADAE", "ADCM")]
|
|
| 377 |
#' join_keys(data)["ADCM", "ADCM"] <- adcm_keys |
|
| 378 |
#' join_keys(data)["ADAE", "ADCM"] <- c("STUDYID", "USUBJID")
|
|
| 379 |
#' |
|
| 380 |
#' app <- init( |
|
| 381 |
#' data = data, |
|
| 382 |
#' modules = modules( |
|
| 383 |
#' tm_g_pp_patient_timeline( |
|
| 384 |
#' label = "Patient Timeline", |
|
| 385 |
#' dataname_adae = "ADAE", |
|
| 386 |
#' dataname_adcm = "ADCM", |
|
| 387 |
#' parentname = "ADSL", |
|
| 388 |
#' patient_col = "USUBJID", |
|
| 389 |
#' plot_height = c(600L, 200L, 2000L), |
|
| 390 |
#' cmdecod = choices_selected( |
|
| 391 |
#' choices = variable_choices(data[["ADCM"]], "CMDECOD"), |
|
| 392 |
#' selected = "CMDECOD", |
|
| 393 |
#' ), |
|
| 394 |
#' aeterm = choices_selected( |
|
| 395 |
#' choices = variable_choices(data[["ADAE"]], "AETERM"), |
|
| 396 |
#' selected = c("AETERM")
|
|
| 397 |
#' ), |
|
| 398 |
#' aetime_start = choices_selected( |
|
| 399 |
#' choices = variable_choices(data[["ADAE"]], "ASTDTM"), |
|
| 400 |
#' selected = c("ASTDTM")
|
|
| 401 |
#' ), |
|
| 402 |
#' aetime_end = choices_selected( |
|
| 403 |
#' choices = variable_choices(data[["ADAE"]], "AENDTM"), |
|
| 404 |
#' selected = c("AENDTM")
|
|
| 405 |
#' ), |
|
| 406 |
#' dstime_start = choices_selected( |
|
| 407 |
#' choices = variable_choices(data[["ADCM"]], "CMASTDTM"), |
|
| 408 |
#' selected = c("CMASTDTM")
|
|
| 409 |
#' ), |
|
| 410 |
#' dstime_end = choices_selected( |
|
| 411 |
#' choices = variable_choices(data[["ADCM"]], "CMAENDTM"), |
|
| 412 |
#' selected = c("CMAENDTM")
|
|
| 413 |
#' ), |
|
| 414 |
#' aerelday_start = choices_selected( |
|
| 415 |
#' choices = variable_choices(data[["ADAE"]], "ASTDY"), |
|
| 416 |
#' selected = c("ASTDY")
|
|
| 417 |
#' ), |
|
| 418 |
#' aerelday_end = choices_selected( |
|
| 419 |
#' choices = variable_choices(data[["ADAE"]], "AENDY"), |
|
| 420 |
#' selected = c("AENDY")
|
|
| 421 |
#' ), |
|
| 422 |
#' dsrelday_start = choices_selected( |
|
| 423 |
#' choices = variable_choices(data[["ADCM"]], "ASTDY"), |
|
| 424 |
#' selected = c("ASTDY")
|
|
| 425 |
#' ), |
|
| 426 |
#' dsrelday_end = choices_selected( |
|
| 427 |
#' choices = variable_choices(data[["ADCM"]], "AENDY"), |
|
| 428 |
#' selected = c("AENDY")
|
|
| 429 |
#' ) |
|
| 430 |
#' ) |
|
| 431 |
#' ) |
|
| 432 |
#' ) |
|
| 433 |
#' if (interactive()) {
|
|
| 434 |
#' shinyApp(app$ui, app$server) |
|
| 435 |
#' } |
|
| 436 |
#' |
|
| 437 |
#' @export |
|
| 438 |
tm_g_pp_patient_timeline <- function(label, |
|
| 439 |
dataname_adcm = "ADCM", |
|
| 440 |
dataname_adae = "ADAE", |
|
| 441 |
parentname = "ADSL", |
|
| 442 |
patient_col = "USUBJID", |
|
| 443 |
aeterm = NULL, |
|
| 444 |
cmdecod = NULL, |
|
| 445 |
aetime_start = NULL, |
|
| 446 |
aetime_end = NULL, |
|
| 447 |
dstime_start = NULL, |
|
| 448 |
dstime_end = NULL, |
|
| 449 |
aerelday_start = NULL, |
|
| 450 |
aerelday_end = NULL, |
|
| 451 |
dsrelday_start = NULL, |
|
| 452 |
dsrelday_end = NULL, |
|
| 453 |
font_size = c(12L, 12L, 25L), |
|
| 454 |
plot_height = c(700L, 200L, 2000L), |
|
| 455 |
plot_width = NULL, |
|
| 456 |
pre_output = NULL, |
|
| 457 |
post_output = NULL, |
|
| 458 |
ggplot2_args = teal.widgets::ggplot2_args()) {
|
|
| 459 | ! |
message("Initializing tm_g_pp_patient_timeline")
|
| 460 | ! |
checkmate::assert_string(label) |
| 461 | ! |
checkmate::assert_string(dataname_adcm) |
| 462 | ! |
checkmate::assert_string(dataname_adae) |
| 463 | ! |
checkmate::assert_string(parentname) |
| 464 | ! |
checkmate::assert_string(patient_col) |
| 465 | ! |
checkmate::assert_class(aeterm, "choices_selected", null.ok = TRUE) |
| 466 | ! |
checkmate::assert_class(cmdecod, "choices_selected", null.ok = TRUE) |
| 467 | ! |
checkmate::assert_class(aetime_start, "choices_selected", null.ok = TRUE) |
| 468 | ! |
checkmate::assert_class(aetime_end, "choices_selected", null.ok = TRUE) |
| 469 | ! |
checkmate::assert_class(dstime_start, "choices_selected", null.ok = TRUE) |
| 470 | ! |
checkmate::assert_class(dstime_end, "choices_selected", null.ok = TRUE) |
| 471 | ! |
checkmate::assert_class(aerelday_start, "choices_selected", null.ok = TRUE) |
| 472 | ! |
checkmate::assert_class(aerelday_end, "choices_selected", null.ok = TRUE) |
| 473 | ! |
checkmate::assert_class(dsrelday_start, "choices_selected", null.ok = TRUE) |
| 474 | ! |
checkmate::assert_class(dsrelday_end, "choices_selected", null.ok = TRUE) |
| 475 | ! |
checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE) |
| 476 | ! |
checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") |
| 477 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
| 478 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
| 479 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
| 480 | ! |
checkmate::assert_numeric( |
| 481 | ! |
plot_width[1], |
| 482 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
| 483 |
) |
|
| 484 | ||
| 485 | ! |
xor_error_string <- function(x, y) {
|
| 486 | ! |
paste( |
| 487 | ! |
"Assertion on `", x, "` and `", y, "` failed:", |
| 488 | ! |
"Both `", x, "` and `", y, "` needs to be provided or both need to be `NULL`." |
| 489 |
) |
|
| 490 |
} |
|
| 491 | ||
| 492 | ! |
if (xor(is.null(aetime_start), is.null(aetime_end))) stop(xor_error_string("aetime_start", "aetime_end"))
|
| 493 | ! |
if (xor(is.null(dstime_start), is.null(dstime_end))) stop(xor_error_string("dstime_start", "dstime_end"))
|
| 494 | ! |
if (xor(is.null(aerelday_start), is.null(aerelday_end))) stop(xor_error_string("aerelday_start", "aerelday_end"))
|
| 495 | ! |
if (xor(is.null(dsrelday_start), is.null(dsrelday_end))) stop(xor_error_string("dsrelday_start", "dsrelday_end"))
|
| 496 | ||
| 497 | ! |
if (is.null(aeterm) && is.null(cmdecod)) {
|
| 498 | ! |
stop("At least one of 'aeterm' or 'cmdecod' needs to be provided.")
|
| 499 |
} |
|
| 500 | ! |
if (!is.null(aeterm) && (is.null(aetime_start) || is.null(aerelday_start))) {
|
| 501 | ! |
stop("If 'aeterm' is provided, then one of 'aetime_start' and 'aerelday_start' must not be empty.")
|
| 502 |
} |
|
| 503 | ! |
if (!is.null(cmdecod) && (is.null(dstime_start) || is.null(dsrelday_start))) {
|
| 504 | ! |
stop("If 'cmdecod' is provided, then one of 'dstime_start' and 'dsrelday_start' must not be empty.")
|
| 505 |
} |
|
| 506 | ||
| 507 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 508 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 509 | ! |
checkmate::assert_class(ggplot2_args, "ggplot2_args") |
| 510 | ||
| 511 | ! |
args <- as.list(environment()) |
| 512 | ! |
data_extract_list <- list( |
| 513 | ! |
aeterm = `if`(is.null(aeterm), NULL, cs_to_des_select(aeterm, dataname = dataname_adae)), |
| 514 | ! |
cmdecod = `if`(is.null(cmdecod), NULL, cs_to_des_select(cmdecod, dataname = dataname_adcm)), |
| 515 | ! |
aetime_start = `if`(is.null(aetime_start), NULL, cs_to_des_select(aetime_start, dataname = dataname_adae)), |
| 516 | ! |
aetime_end = `if`(is.null(aetime_end), NULL, cs_to_des_select(aetime_end, dataname = dataname_adae)), |
| 517 | ! |
dstime_start = `if`(is.null(dstime_start), NULL, cs_to_des_select(dstime_start, dataname = dataname_adcm)), |
| 518 | ! |
dstime_end = `if`(is.null(dstime_end), NULL, cs_to_des_select(dstime_end, dataname = dataname_adcm)), |
| 519 | ! |
aerelday_start = `if`(is.null(aerelday_start), NULL, cs_to_des_select(aerelday_start, dataname = dataname_adae)), |
| 520 | ! |
aerelday_end = `if`(is.null(aerelday_end), NULL, cs_to_des_select(aerelday_end, dataname = dataname_adae)), |
| 521 | ! |
dsrelday_start = `if`(is.null(dsrelday_start), NULL, cs_to_des_select(dsrelday_start, dataname = dataname_adcm)), |
| 522 | ! |
dsrelday_end = `if`(is.null(dsrelday_end), NULL, cs_to_des_select(dsrelday_end, dataname = dataname_adcm)) |
| 523 |
) |
|
| 524 | ||
| 525 | ! |
module( |
| 526 | ! |
label = label, |
| 527 | ! |
ui = ui_g_patient_timeline, |
| 528 | ! |
ui_args = c(data_extract_list, args), |
| 529 | ! |
server = srv_g_patient_timeline, |
| 530 | ! |
server_args = c( |
| 531 | ! |
data_extract_list, |
| 532 | ! |
list( |
| 533 | ! |
dataname_adae = dataname_adae, |
| 534 | ! |
dataname_adcm = dataname_adcm, |
| 535 | ! |
parentname = parentname, |
| 536 | ! |
label = label, |
| 537 | ! |
patient_col = patient_col, |
| 538 | ! |
plot_height = plot_height, |
| 539 | ! |
plot_width = plot_width, |
| 540 | ! |
ggplot2_args = ggplot2_args |
| 541 |
) |
|
| 542 |
), |
|
| 543 | ! |
datanames = c(dataname_adcm, dataname_adae, parentname) |
| 544 |
) |
|
| 545 |
} |
|
| 546 | ||
| 547 |
#' @keywords internal |
|
| 548 |
ui_g_patient_timeline <- function(id, ...) {
|
|
| 549 | ! |
ui_args <- list(...) |
| 550 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 551 | ! |
ui_args$aeterm, |
| 552 | ! |
ui_args$cmdecod, |
| 553 | ! |
ui_args$aetime_start, |
| 554 | ! |
ui_args$aetime_end, |
| 555 | ! |
ui_args$dstime_start, |
| 556 | ! |
ui_args$dstime_end, |
| 557 | ! |
ui_args$aerelday_start, |
| 558 | ! |
ui_args$aerelday_end, |
| 559 | ! |
ui_args$dsrelday_start, |
| 560 | ! |
ui_args$dsrelday_end |
| 561 |
) |
|
| 562 | ||
| 563 | ! |
ns <- NS(id) |
| 564 | ! |
teal.widgets::standard_layout( |
| 565 | ! |
output = teal.widgets::plot_with_settings_ui(id = ns("patient_timeline_plot")),
|
| 566 | ! |
encoding = tags$div( |
| 567 |
### Reporter |
|
| 568 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 569 |
### |
|
| 570 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 571 | ! |
teal.transform::datanames_input( |
| 572 | ! |
ui_args[c( |
| 573 | ! |
"aeterm", "cmdecod", |
| 574 | ! |
"aetime_start", "aetime_end", "dstime_start", "dstime_end", |
| 575 | ! |
"aerelday_start", "aerelday_end", "dsrelday_start", "dsrelday_end" |
| 576 |
)] |
|
| 577 |
), |
|
| 578 | ! |
teal.widgets::optionalSelectInput( |
| 579 | ! |
ns("patient_id"),
|
| 580 | ! |
"Select Patient:", |
| 581 | ! |
multiple = FALSE, |
| 582 | ! |
options = shinyWidgets::pickerOptions(`liveSearch` = TRUE) |
| 583 |
), |
|
| 584 | ! |
teal.transform::data_extract_ui( |
| 585 | ! |
id = ns("cmdecod"),
|
| 586 | ! |
label = "Select Medication standardized term variable:", |
| 587 | ! |
data_extract_spec = ui_args$cmdecod, |
| 588 | ! |
is_single_dataset = is_single_dataset_value |
| 589 |
), |
|
| 590 | ! |
teal.transform::data_extract_ui( |
| 591 | ! |
id = ns("aeterm"),
|
| 592 | ! |
label = "Select AE reported term variable:", |
| 593 | ! |
data_extract_spec = ui_args$aeterm, |
| 594 | ! |
is_single_dataset = is_single_dataset_value |
| 595 |
), |
|
| 596 | ! |
if (!is.null(ui_args$aerelday_start) || !is.null(ui_args$dsrelday_start)) {
|
| 597 | ! |
tagList( |
| 598 | ! |
checkboxInput(ns("relday_x_axis"), label = "Use relative days on the x-axis", value = TRUE),
|
| 599 | ! |
conditionalPanel( |
| 600 | ! |
paste0("input.relday_x_axis == true"),
|
| 601 | ! |
ns = ns, |
| 602 | ! |
if (!is.null(ui_args$aerelday_start)) {
|
| 603 | ! |
tagList( |
| 604 | ! |
teal.transform::data_extract_ui( |
| 605 | ! |
id = ns("aerelday_start"),
|
| 606 | ! |
label = "Select AE relative start date variable:", |
| 607 | ! |
data_extract_spec = ui_args$aerelday_start, |
| 608 | ! |
is_single_dataset = is_single_dataset_value |
| 609 |
), |
|
| 610 | ! |
teal.transform::data_extract_ui( |
| 611 | ! |
id = ns("aerelday_end"),
|
| 612 | ! |
label = "Select AE relative end date variable:", |
| 613 | ! |
data_extract_spec = ui_args$aerelday_end, |
| 614 | ! |
is_single_dataset = is_single_dataset_value |
| 615 |
) |
|
| 616 |
) |
|
| 617 |
}, |
|
| 618 | ! |
if (!is.null(ui_args$dsrelday_start)) {
|
| 619 | ! |
tagList( |
| 620 | ! |
teal.transform::data_extract_ui( |
| 621 | ! |
id = ns("dsrelday_start"),
|
| 622 | ! |
label = "Select Medication relative start date variable:", |
| 623 | ! |
data_extract_spec = ui_args$dsrelday_start, |
| 624 | ! |
is_single_dataset = is_single_dataset_value |
| 625 |
), |
|
| 626 | ! |
teal.transform::data_extract_ui( |
| 627 | ! |
id = ns("dsrelday_end"),
|
| 628 | ! |
label = "Select Medication relative end date variable:", |
| 629 | ! |
data_extract_spec = ui_args$dsrelday_end, |
| 630 | ! |
is_single_dataset = is_single_dataset_value |
| 631 |
) |
|
| 632 |
) |
|
| 633 |
} |
|
| 634 |
) |
|
| 635 |
) |
|
| 636 |
} else {
|
|
| 637 | ! |
shinyjs::hidden(checkboxInput(ns("relday_x_axis"), label = "", value = FALSE))
|
| 638 |
}, |
|
| 639 | ! |
conditionalPanel( |
| 640 | ! |
paste0("input.relday_x_axis == false"),
|
| 641 | ! |
ns = ns, |
| 642 | ! |
teal.transform::data_extract_ui( |
| 643 | ! |
id = ns("aetime_start"),
|
| 644 | ! |
label = "Select ASTDTM variable:", |
| 645 | ! |
data_extract_spec = ui_args$aetime_start, |
| 646 | ! |
is_single_dataset = is_single_dataset_value |
| 647 |
), |
|
| 648 | ! |
teal.transform::data_extract_ui( |
| 649 | ! |
id = ns("aetime_end"),
|
| 650 | ! |
label = "Select AENDTM variable:", |
| 651 | ! |
data_extract_spec = ui_args$aetime_end, |
| 652 | ! |
is_single_dataset = is_single_dataset_value |
| 653 |
), |
|
| 654 | ! |
teal.transform::data_extract_ui( |
| 655 | ! |
id = ns("dstime_start"),
|
| 656 | ! |
label = "Select TRTSDTM variable:", |
| 657 | ! |
data_extract_spec = ui_args$dstime_start, |
| 658 | ! |
is_single_dataset = is_single_dataset_value |
| 659 |
), |
|
| 660 | ! |
teal.transform::data_extract_ui( |
| 661 | ! |
id = ns("dstime_end"),
|
| 662 | ! |
label = "Select TRTEDTM variable:", |
| 663 | ! |
data_extract_spec = ui_args$dstime_end, |
| 664 | ! |
is_single_dataset = is_single_dataset_value |
| 665 |
) |
|
| 666 |
), |
|
| 667 | ! |
teal.widgets::panel_item( |
| 668 | ! |
title = "Plot settings", |
| 669 | ! |
collapsed = TRUE, |
| 670 | ! |
teal.widgets::optionalSliderInputValMinMax( |
| 671 | ! |
ns("font_size"),
|
| 672 | ! |
"Font Size", |
| 673 | ! |
ui_args$font_size, |
| 674 | ! |
ticks = FALSE, |
| 675 | ! |
step = 1 |
| 676 |
) |
|
| 677 |
) |
|
| 678 |
), |
|
| 679 | ! |
forms = tagList( |
| 680 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 681 |
), |
|
| 682 | ! |
pre_output = ui_args$pre_output, |
| 683 | ! |
post_output = ui_args$post_output |
| 684 |
) |
|
| 685 |
} |
|
| 686 | ||
| 687 |
#' @keywords internal |
|
| 688 |
srv_g_patient_timeline <- function(id, |
|
| 689 |
data, |
|
| 690 |
reporter, |
|
| 691 |
filter_panel_api, |
|
| 692 |
dataname_adae, |
|
| 693 |
dataname_adcm, |
|
| 694 |
parentname, |
|
| 695 |
patient_col, |
|
| 696 |
aeterm, |
|
| 697 |
cmdecod, |
|
| 698 |
aetime_start, |
|
| 699 |
aetime_end, |
|
| 700 |
dstime_start, |
|
| 701 |
dstime_end, |
|
| 702 |
aerelday_start, |
|
| 703 |
aerelday_end, |
|
| 704 |
dsrelday_start, |
|
| 705 |
dsrelday_end, |
|
| 706 |
plot_height, |
|
| 707 |
plot_width, |
|
| 708 |
label, |
|
| 709 |
ggplot2_args) {
|
|
| 710 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 711 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 712 | ! |
checkmate::assert_class(data, "reactive") |
| 713 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
| 714 | ||
| 715 | ! |
moduleServer(id, function(input, output, session) {
|
| 716 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 717 | ! |
patient_id <- reactive(input$patient_id) |
| 718 | ||
| 719 |
# Init |
|
| 720 | ! |
patient_data_base <- reactive(unique(data()[[parentname]][[patient_col]])) |
| 721 | ! |
teal.widgets::updateOptionalSelectInput( |
| 722 | ! |
session, |
| 723 | ! |
"patient_id", |
| 724 | ! |
choices = patient_data_base(), |
| 725 | ! |
selected = patient_data_base()[1] |
| 726 |
) |
|
| 727 | ||
| 728 | ! |
observeEvent(patient_data_base(), |
| 729 | ! |
handlerExpr = {
|
| 730 | ! |
teal.widgets::updateOptionalSelectInput( |
| 731 | ! |
session, |
| 732 | ! |
"patient_id", |
| 733 | ! |
choices = patient_data_base(), |
| 734 | ! |
selected = if (length(patient_data_base()) == 1) {
|
| 735 | ! |
patient_data_base() |
| 736 |
} else {
|
|
| 737 | ! |
intersect(patient_id(), patient_data_base()) |
| 738 |
} |
|
| 739 |
) |
|
| 740 |
}, |
|
| 741 | ! |
ignoreInit = TRUE |
| 742 |
) |
|
| 743 | ||
| 744 |
# Patient timeline tab ---- |
|
| 745 | ! |
check_box <- reactive(input$relday_x_axis) |
| 746 | ||
| 747 | ! |
check_relative <- function(main_param, return_name) {
|
| 748 | ! |
function(value) {
|
| 749 | ! |
if (length(selector_list()[[main_param]]()$select) > 0 && length(value) == 0) {
|
| 750 | ! |
sprintf("Please add %s", return_name)
|
| 751 |
} |
|
| 752 |
} |
|
| 753 |
} |
|
| 754 | ||
| 755 | ! |
rule_one_parameter <- function(other) {
|
| 756 | ! |
function(value) {
|
| 757 | ! |
if (length(value) == 0L && length(selector_list()[[other]]()$select) == 0L) {
|
| 758 | ! |
"At least one term variable must be selected." |
| 759 |
} |
|
| 760 |
} |
|
| 761 |
} |
|
| 762 | ||
| 763 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 764 | ! |
data_extract = list( |
| 765 | ! |
dsrelday_start = dsrelday_start, dsrelday_end = dsrelday_end, |
| 766 | ! |
aerelday_start = aerelday_start, aerelday_end = aerelday_end, |
| 767 | ! |
aeterm = aeterm, aetime_start = aetime_start, |
| 768 | ! |
aetime_end = aetime_end, dstime_start = dstime_start, dstime_end = dstime_end, cmdecod = cmdecod |
| 769 |
), |
|
| 770 | ! |
datasets = data, |
| 771 | ! |
select_validation_rule = list( |
| 772 |
# aeterm |
|
| 773 | ! |
aeterm = rule_one_parameter("cmdecod"),
|
| 774 | ! |
aerelday_start = check_relative("aeterm", "AE start date."),
|
| 775 | ! |
aerelday_end = check_relative("aeterm", "AE end date."),
|
| 776 | ! |
aetime_start = check_relative("aeterm", "AE start date."),
|
| 777 | ! |
aetime_end = check_relative("aeterm", "AE end date."),
|
| 778 |
# cmdecod |
|
| 779 | ! |
cmdecod = rule_one_parameter("aeterm"),
|
| 780 | ! |
dsrelday_start = check_relative("cmdecod", "Medication start date."),
|
| 781 | ! |
dsrelday_end = check_relative("cmdecod", "Medication end date."),
|
| 782 | ! |
dstime_start = check_relative("cmdecod", "Medication start date."),
|
| 783 | ! |
dstime_end = check_relative("cmdecod", "Medication end date.")
|
| 784 |
) |
|
| 785 |
) |
|
| 786 | ||
| 787 | ! |
iv_r <- reactive({
|
| 788 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 789 | ! |
iv$add_rule("patient_id", shinyvalidate::sv_required("Please select a patient"))
|
| 790 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 791 |
}) |
|
| 792 | ||
| 793 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 794 | ! |
datasets = data, |
| 795 | ! |
selector_list = selector_list |
| 796 |
) |
|
| 797 | ||
| 798 | ! |
anl_q <- reactive({
|
| 799 | ! |
data() %>% |
| 800 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) |
| 801 |
}) |
|
| 802 | ||
| 803 | ! |
all_q <- reactive({
|
| 804 | ! |
teal::validate_inputs(iv_r()) |
| 805 | ||
| 806 | ! |
aeterm <- input[[extract_input("aeterm", dataname_adae)]]
|
| 807 | ! |
aetime_start <- input[[extract_input("aetime_start", dataname_adae)]]
|
| 808 | ! |
aetime_end <- input[[extract_input("aetime_end", dataname_adae)]]
|
| 809 | ! |
dstime_start <- input[[extract_input("dstime_start", dataname_adcm)]]
|
| 810 | ! |
dstime_end <- input[[extract_input("dstime_end", dataname_adcm)]]
|
| 811 | ! |
cmdecod <- input[[extract_input("cmdecod", dataname_adcm)]]
|
| 812 | ! |
aerelday_start <- input[[extract_input("aerelday_start", dataname_adae)]]
|
| 813 | ! |
aerelday_end <- input[[extract_input("aerelday_end", dataname_adae)]]
|
| 814 | ! |
dsrelday_start <- input[[extract_input("dsrelday_start", dataname_adcm)]]
|
| 815 | ! |
dsrelday_end <- input[[extract_input("dsrelday_end", dataname_adcm)]]
|
| 816 | ! |
font_size <- input[["font_size"]] |
| 817 | ||
| 818 | ! |
ae_chart_vars_null <- any(vapply(list(aeterm, aetime_start, aetime_end), is.null, FUN.VALUE = logical(1))) |
| 819 | ! |
ds_chart_vars_null <- any(vapply(list(cmdecod, dstime_start, dstime_end), is.null, FUN.VALUE = logical(1))) |
| 820 | ||
| 821 | ! |
p_timeline_data <- anl_q()[["ANL"]] |
| 822 |
# time variables can not be NA |
|
| 823 | ! |
p_time_data_pat <- p_timeline_data[p_timeline_data[[patient_col]] == patient_id(), ] |
| 824 | ||
| 825 | ! |
validate( |
| 826 | ! |
need( |
| 827 | ! |
input$relday_x_axis || |
| 828 |
( |
|
| 829 | ! |
sum(stats::complete.cases(p_time_data_pat[, c(aetime_start, aetime_end)])) > 0 || |
| 830 | ! |
sum(stats::complete.cases(p_time_data_pat[, c(dstime_start, dstime_end)])) > 0 |
| 831 |
), |
|
| 832 | ! |
"Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." |
| 833 |
) |
|
| 834 |
) |
|
| 835 | ||
| 836 | ! |
aerel_chart_vars_null <- any(vapply(list(aeterm, aerelday_start, aerelday_end), is.null, FUN.VALUE = logical(1))) |
| 837 | ! |
dsrel_chart_vars_null <- any(vapply(list(cmdecod, dsrelday_start, dsrelday_end), is.null, FUN.VALUE = logical(1))) |
| 838 | ||
| 839 |
# These lines are needed because there is a naming conflict: ADCM and ADAE will be both pass in their ASTDY and |
|
| 840 |
# AENDY columns to data_merge_module call above. |
|
| 841 | ! |
aerelday_start_name <- `if`( |
| 842 | ! |
length(aerelday_start), |
| 843 | ! |
anl_inputs()$columns_source$aerelday_start[[1]], |
| 844 | ! |
aerelday_start |
| 845 |
) |
|
| 846 | ! |
aerelday_end_name <- `if`( |
| 847 | ! |
length(aerelday_end), |
| 848 | ! |
anl_inputs()$columns_source$aerelday_end[[1]], |
| 849 | ! |
aerelday_end |
| 850 |
) |
|
| 851 | ! |
dsrelday_start_name <- `if`( |
| 852 | ! |
length(dsrelday_start), |
| 853 | ! |
anl_inputs()$columns_source$dsrelday_start[[1]], |
| 854 | ! |
dsrelday_start |
| 855 |
) |
|
| 856 | ! |
dsrelday_end_name <- `if`( |
| 857 | ! |
length(dsrelday_end), |
| 858 | ! |
anl_inputs()$columns_source$dsrelday_end[[1]], |
| 859 | ! |
dsrelday_end |
| 860 |
) |
|
| 861 | ||
| 862 | ! |
validate( |
| 863 | ! |
need( |
| 864 | ! |
!input$relday_x_axis || |
| 865 |
( |
|
| 866 | ! |
sum(stats::complete.cases(p_time_data_pat[, c(aerelday_start_name, aerelday_end_name)])) > 0 || |
| 867 | ! |
sum(stats::complete.cases(p_time_data_pat[, c(dsrelday_start_name, dsrelday_end_name)])) > 0 |
| 868 |
), |
|
| 869 | ! |
"Selected patient is not in dataset (either due to filtering or missing values). Consider relaxing filters." |
| 870 |
) |
|
| 871 |
) |
|
| 872 | ||
| 873 | ! |
patient_timeline_calls <- template_patient_timeline( |
| 874 | ! |
dataname = "ANL", |
| 875 | ! |
aeterm = aeterm, |
| 876 | ! |
aetime_start = aetime_start, |
| 877 | ! |
aetime_end = aetime_end, |
| 878 | ! |
dstime_start = dstime_start, |
| 879 | ! |
dstime_end = dstime_end, |
| 880 | ! |
cmdecod = cmdecod, |
| 881 | ! |
aerelday_start = aerelday_start_name, |
| 882 | ! |
aerelday_end = aerelday_end_name, |
| 883 | ! |
dsrelday_start = dsrelday_start_name, |
| 884 | ! |
dsrelday_end = dsrelday_end_name, |
| 885 | ! |
font_size = font_size, |
| 886 | ! |
relative_day = input$relday_x_axis, |
| 887 | ! |
patient_id = patient_id(), |
| 888 | ! |
ggplot2_args = ggplot2_args |
| 889 |
) |
|
| 890 | ||
| 891 | ! |
qenv <- teal.code::eval_code( |
| 892 | ! |
anl_q(), |
| 893 | ! |
substitute( |
| 894 | ! |
expr = {
|
| 895 | ! |
ANL <- ANL[ANL[[patient_col]] == patient_id, ] |
| 896 | ! |
}, env = list( |
| 897 | ! |
patient_col = patient_col, |
| 898 | ! |
patient_id = patient_id() |
| 899 |
) |
|
| 900 |
) |
|
| 901 |
) |
|
| 902 | ||
| 903 | ! |
teal.code::eval_code(object = qenv, as.expression(patient_timeline_calls)) |
| 904 |
}) |
|
| 905 | ||
| 906 | ! |
plot_r <- reactive(all_q()[["patient_timeline_plot"]]) |
| 907 | ||
| 908 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 909 | ! |
id = "patient_timeline_plot", |
| 910 | ! |
plot_r = plot_r, |
| 911 | ! |
height = plot_height, |
| 912 | ! |
width = plot_width |
| 913 |
) |
|
| 914 | ||
| 915 | ! |
teal.widgets::verbatim_popup_srv( |
| 916 | ! |
id = "rcode", |
| 917 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 918 | ! |
title = label |
| 919 |
) |
|
| 920 | ||
| 921 |
### REPORTER |
|
| 922 | ! |
if (with_reporter) {
|
| 923 | ! |
card_fun <- function(comment, label) {
|
| 924 | ! |
card <- teal::report_card_template( |
| 925 | ! |
title = "Patient Profile Timeline Plot", |
| 926 | ! |
label = label, |
| 927 | ! |
with_filter = with_filter, |
| 928 | ! |
filter_panel_api = filter_panel_api |
| 929 |
) |
|
| 930 | ! |
card$append_text("Plot", "header3")
|
| 931 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
| 932 | ! |
if (!comment == "") {
|
| 933 | ! |
card$append_text("Comment", "header3")
|
| 934 | ! |
card$append_text(comment) |
| 935 |
} |
|
| 936 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 937 | ! |
card |
| 938 |
} |
|
| 939 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 940 |
} |
|
| 941 |
### |
|
| 942 |
}) |
|
| 943 |
} |
| 1 |
#' Template: Multiple Events by Term |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a table of multiple events by term. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @param seq_var (`character`)\cr name of analysis sequence number variable. Used for counting the unique number |
|
| 7 |
#' of events. |
|
| 8 |
#' |
|
| 9 |
#' @inherit template_arguments return |
|
| 10 |
#' |
|
| 11 |
#' @seealso [tm_t_mult_events()] |
|
| 12 |
#' |
|
| 13 |
#' @keywords internal |
|
| 14 |
template_mult_events <- function(dataname, |
|
| 15 |
parentname, |
|
| 16 |
arm_var, |
|
| 17 |
seq_var, |
|
| 18 |
hlt, |
|
| 19 |
llt, |
|
| 20 |
add_total = TRUE, |
|
| 21 |
total_label = default_total_label(), |
|
| 22 |
na_level = default_na_str(), |
|
| 23 |
event_type = "event", |
|
| 24 |
drop_arm_levels = TRUE, |
|
| 25 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 26 | 6x |
checkmate::assert_string(dataname) |
| 27 | 6x |
checkmate::assert_string(parentname) |
| 28 | 6x |
checkmate::assert_string(arm_var) |
| 29 | 6x |
checkmate::assert_string(seq_var) |
| 30 | 6x |
checkmate::assert_character(hlt, null.ok = TRUE) |
| 31 | 6x |
checkmate::assert_string(llt, null.ok = FALSE) |
| 32 | 6x |
checkmate::assert_flag(add_total) |
| 33 | 6x |
checkmate::assert_string(total_label) |
| 34 | 6x |
checkmate::assert_string(na_level) |
| 35 | 6x |
checkmate::assert_string(event_type) |
| 36 | 6x |
checkmate::assert_flag(drop_arm_levels) |
| 37 | ||
| 38 | 6x |
y <- list() |
| 39 | ||
| 40 |
# Start data steps. |
|
| 41 | 6x |
data_list <- list() |
| 42 | ||
| 43 | 6x |
data_list <- add_expr( |
| 44 | 6x |
data_list, |
| 45 | 6x |
substitute( |
| 46 | 6x |
expr = anl <- df, |
| 47 | 6x |
env = list(df = as.name(dataname)) |
| 48 |
) |
|
| 49 |
) |
|
| 50 | ||
| 51 | 6x |
data_list <- add_expr( |
| 52 | 6x |
data_list, |
| 53 | 6x |
prepare_arm_levels( |
| 54 | 6x |
dataname = "anl", |
| 55 | 6x |
parentname = parentname, |
| 56 | 6x |
arm_var = arm_var, |
| 57 | 6x |
drop_arm_levels = drop_arm_levels |
| 58 |
) |
|
| 59 |
) |
|
| 60 | ||
| 61 | 6x |
if (is.null(hlt)) {
|
| 62 | 1x |
term_vars <- c(llt) |
| 63 |
} else {
|
|
| 64 | 5x |
term_vars <- c(hlt, llt) |
| 65 |
} |
|
| 66 | ||
| 67 | 6x |
data_list <- add_expr( |
| 68 | 6x |
data_list, |
| 69 | 6x |
substitute( |
| 70 | 6x |
expr = anl <- anl %>% |
| 71 | 6x |
df_explicit_na(omit_columns = setdiff(names(anl), term_vars)), |
| 72 | 6x |
env = list( |
| 73 | 6x |
term_vars = term_vars |
| 74 |
) |
|
| 75 |
) |
|
| 76 |
) |
|
| 77 | ||
| 78 | 6x |
data_list <- add_expr( |
| 79 | 6x |
data_list, |
| 80 | 6x |
substitute_names( |
| 81 | 6x |
expr = anl <- anl %>% |
| 82 | 6x |
dplyr::mutate(seq_var = as.factor(seq_var)), |
| 83 | 6x |
names = list( |
| 84 | 6x |
seq_var = as.name(seq_var) |
| 85 |
) |
|
| 86 |
) |
|
| 87 |
) |
|
| 88 | ||
| 89 | 6x |
data_list <- add_expr( |
| 90 | 6x |
data_list, |
| 91 | 6x |
substitute( |
| 92 | 6x |
expr = parentname <- df_explicit_na(parentname, na_level = na_str), |
| 93 | 6x |
env = list(parentname = as.name(parentname), na_str = na_level) |
| 94 |
) |
|
| 95 |
) |
|
| 96 | ||
| 97 | 6x |
y$data <- bracket_expr(data_list) |
| 98 | ||
| 99 | 6x |
y$layout_prep <- quote(split_fun <- drop_split_levels) |
| 100 | ||
| 101 | 6x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 102 | 6x |
teal.widgets::resolve_basic_table_args( |
| 103 | 6x |
user_table = basic_table_args, |
| 104 | 6x |
module_table = teal.widgets::basic_table_args(show_colcounts = TRUE) |
| 105 |
) |
|
| 106 |
) |
|
| 107 | ||
| 108 |
# Start layout steps. |
|
| 109 | 6x |
layout_list <- list() |
| 110 | ||
| 111 | 6x |
layout_list <- add_expr(layout_list, parsed_basic_table_args) |
| 112 | 6x |
layout_list <- add_expr( |
| 113 | 6x |
layout_list, |
| 114 | 6x |
substitute( |
| 115 | 6x |
expr = rtables::split_cols_by(var = arm_var), |
| 116 | 6x |
env = list(arm_var = arm_var) |
| 117 |
) |
|
| 118 |
) |
|
| 119 | ||
| 120 | 6x |
if (add_total) {
|
| 121 | 5x |
layout_list <- add_expr( |
| 122 | 5x |
layout_list, |
| 123 | 5x |
substitute( |
| 124 | 5x |
expr = rtables::add_overall_col(label = total_label), |
| 125 | 5x |
env = list(total_label = total_label) |
| 126 |
) |
|
| 127 |
) |
|
| 128 |
} |
|
| 129 | ||
| 130 | 6x |
unique_label <- paste0("Total number of patients with at least one ", event_type)
|
| 131 | 6x |
nonunique_label <- paste0("Total number of ", event_type, "s")
|
| 132 | ||
| 133 | 6x |
layout_list <- add_expr( |
| 134 | 6x |
layout_list, |
| 135 | 6x |
substitute( |
| 136 | 6x |
summarize_num_patients( |
| 137 | 6x |
var = "USUBJID", |
| 138 | 6x |
count_by = seq_var, |
| 139 | 6x |
.stats = c("unique", "nonunique"),
|
| 140 | 6x |
.labels = c( |
| 141 | 6x |
unique = unique_label, |
| 142 | 6x |
nonunique = nonunique_label |
| 143 |
) |
|
| 144 |
), |
|
| 145 | 6x |
env = list(unique_label = unique_label, nonunique_label = nonunique_label, seq_var = seq_var) |
| 146 |
) |
|
| 147 |
) |
|
| 148 | ||
| 149 | 6x |
if (is.null(hlt)) {
|
| 150 | 1x |
layout_list <- add_expr( |
| 151 | 1x |
layout_list, |
| 152 | 1x |
substitute( |
| 153 | 1x |
expr = count_occurrences(vars = llt, .indent_mods = -1L) %>% |
| 154 | 1x |
append_varlabels(dataname, llt, indent = 0L), |
| 155 | 1x |
env = list( |
| 156 | 1x |
dataname = as.name(dataname), llt = llt |
| 157 |
) |
|
| 158 |
) |
|
| 159 |
) |
|
| 160 |
} else {
|
|
| 161 | 5x |
lbl_lst <- list() |
| 162 | ||
| 163 | 5x |
for (ii in seq_along(hlt)) {
|
| 164 | 11x |
hlt_new <- hlt[ii] |
| 165 | ||
| 166 | 11x |
lbl_lst <- add_expr( |
| 167 | 11x |
lbl_lst, |
| 168 | 11x |
substitute( |
| 169 | 11x |
expr = attr(dataname$hlt_new, which = "label"), |
| 170 | 11x |
env = list( |
| 171 | 11x |
dataname = as.name(dataname), |
| 172 | 11x |
hlt_new = hlt_new |
| 173 |
) |
|
| 174 |
) |
|
| 175 |
) |
|
| 176 | ||
| 177 | 11x |
nested <- ifelse(ii == 1, FALSE, TRUE) |
| 178 | 11x |
indent_mod <- ifelse(ii == 1, -1L, 0L) |
| 179 | ||
| 180 | 11x |
layout_list <- add_expr( |
| 181 | 11x |
layout_list, |
| 182 | 11x |
substitute( |
| 183 | 11x |
expr = |
| 184 | 11x |
rtables::split_rows_by( |
| 185 | 11x |
hlt, |
| 186 | 11x |
child_labels = "visible", |
| 187 | 11x |
nested = nested, |
| 188 | 11x |
indent_mod = indent_mod, |
| 189 | 11x |
split_fun = split_fun, |
| 190 | 11x |
label_pos = "topleft", |
| 191 | 11x |
split_label = teal.data::col_labels(dataname[hlt_new]) |
| 192 |
), |
|
| 193 | 11x |
env = list( |
| 194 | 11x |
hlt = hlt_new, |
| 195 | 11x |
nested = nested, |
| 196 | 11x |
indent_mod = indent_mod, |
| 197 | 11x |
dataname = as.name(dataname), |
| 198 | 11x |
hlt_new = hlt_new |
| 199 |
) |
|
| 200 |
) |
|
| 201 |
) |
|
| 202 |
} |
|
| 203 | ||
| 204 | 5x |
layout_list <- add_expr( |
| 205 | 5x |
layout_list, |
| 206 | 5x |
substitute( |
| 207 | 5x |
expr = summarize_num_patients( |
| 208 | 5x |
var = "USUBJID", |
| 209 | 5x |
count_by = seq_var, |
| 210 | 5x |
.stats = c("unique", "nonunique"),
|
| 211 | 5x |
.labels = c( |
| 212 | 5x |
unique = unique_label, |
| 213 | 5x |
nonunique = nonunique_label |
| 214 |
) |
|
| 215 |
) %>% |
|
| 216 | 5x |
count_occurrences(vars = llt, .indent_mods = -1L) %>% |
| 217 | 5x |
append_varlabels(dataname, llt, indent = indent_space), |
| 218 | 5x |
env = list( |
| 219 | 5x |
dataname = as.name(dataname), llt = llt, |
| 220 | 5x |
unique_label = unique_label, nonunique_label = nonunique_label, |
| 221 | 5x |
seq_var = seq_var, |
| 222 | 5x |
indent_space = length(hlt) |
| 223 |
) |
|
| 224 |
) |
|
| 225 |
) |
|
| 226 |
} |
|
| 227 | ||
| 228 | 6x |
lyt <- substitute( |
| 229 | 6x |
expr = lyt <- layout_pipe, |
| 230 | 6x |
env = list(layout_pipe = pipe_expr(layout_list)) |
| 231 |
) |
|
| 232 | ||
| 233 | 6x |
y$layout <- lyt |
| 234 | ||
| 235 |
# Table |
|
| 236 | 6x |
y$table <- substitute( |
| 237 | 6x |
expr = result <- rtables::build_table(lyt = lyt, df = anl, alt_counts_df = parent), |
| 238 | 6x |
env = list( |
| 239 | 6x |
parent = as.name(parentname) |
| 240 |
) |
|
| 241 |
) |
|
| 242 | ||
| 243 |
# Start sorting table |
|
| 244 | 6x |
if (is.null(hlt)) {
|
| 245 | 1x |
pth <- c(llt) |
| 246 |
} else {
|
|
| 247 | 5x |
pth <- c(rbind(hlt, rep("*", length(hlt))), llt)
|
| 248 |
} |
|
| 249 | ||
| 250 | 6x |
sort_list <- list() |
| 251 | ||
| 252 | 6x |
sort_list <- add_expr( |
| 253 | 6x |
sort_list, |
| 254 | 6x |
substitute( |
| 255 | 6x |
expr = sorted_result <- result %>% |
| 256 | 6x |
sort_at_path(path = pth, scorefun = score_occurrences), |
| 257 | 6x |
env = list(pth = pth) |
| 258 |
) |
|
| 259 |
) |
|
| 260 | ||
| 261 | 6x |
y$table_sorted <- bracket_expr(sort_list) |
| 262 | ||
| 263 |
# Combine tables. |
|
| 264 | 6x |
y$final_table <- quote( |
| 265 | 6x |
expr = {
|
| 266 | ! |
result <- sorted_result |
| 267 | ! |
result |
| 268 |
} |
|
| 269 |
) |
|
| 270 | ||
| 271 | 6x |
y |
| 272 |
} |
|
| 273 | ||
| 274 |
#' teal Module: Multiple Events by Term |
|
| 275 |
#' |
|
| 276 |
#' This module produces a table of multiple events by term. |
|
| 277 |
#' |
|
| 278 |
#' @inheritParams module_arguments |
|
| 279 |
#' @inheritParams template_mult_events |
|
| 280 |
#' @param seq_var ([teal.transform::choices_selected()])\cr object with |
|
| 281 |
#' all available choices and preselected option for variable names that can be used as analysis sequence number |
|
| 282 |
#' variable. Used for counting the unique number of events. |
|
| 283 |
#' |
|
| 284 |
#' @inherit module_arguments return seealso |
|
| 285 |
#' |
|
| 286 |
#' @examples |
|
| 287 |
#' ADSL <- tmc_ex_adsl |
|
| 288 |
#' ADCM <- tmc_ex_adcm |
|
| 289 |
#' adcm_keys <- c("STUDYID", "USUBJID", "ASTDTM", "CMSEQ", "ATC1", "ATC2", "ATC3", "ATC4")
|
|
| 290 |
#' |
|
| 291 |
#' join_keys <- default_cdisc_join_keys[c("ADSL", "ADCM")]
|
|
| 292 |
#' join_keys["ADCM", "ADCM"] <- adcm_keys |
|
| 293 |
#' |
|
| 294 |
#' app <- init( |
|
| 295 |
#' data = cdisc_data( |
|
| 296 |
#' ADSL = ADSL, |
|
| 297 |
#' ADCM = ADCM, |
|
| 298 |
#' code = " |
|
| 299 |
#' ADSL <- tmc_ex_adsl |
|
| 300 |
#' ADCM <- tmc_ex_adcm |
|
| 301 |
#' ", |
|
| 302 |
#' join_keys = join_keys |
|
| 303 |
#' ), |
|
| 304 |
#' modules = modules( |
|
| 305 |
#' tm_t_mult_events( |
|
| 306 |
#' label = "Concomitant Medications by Medication Class and Preferred Name", |
|
| 307 |
#' dataname = "ADCM", |
|
| 308 |
#' arm_var = choices_selected(c("ARM", "ARMCD"), "ARM"),
|
|
| 309 |
#' seq_var = choices_selected("CMSEQ", selected = "CMSEQ", fixed = TRUE),
|
|
| 310 |
#' hlt = choices_selected( |
|
| 311 |
#' choices = variable_choices(ADCM, c("ATC1", "ATC2", "ATC3", "ATC4")),
|
|
| 312 |
#' selected = c("ATC1", "ATC2", "ATC3", "ATC4")
|
|
| 313 |
#' ), |
|
| 314 |
#' llt = choices_selected( |
|
| 315 |
#' choices = variable_choices(ADCM, c("CMDECOD")),
|
|
| 316 |
#' selected = c("CMDECOD")
|
|
| 317 |
#' ), |
|
| 318 |
#' add_total = TRUE, |
|
| 319 |
#' event_type = "treatment" |
|
| 320 |
#' ) |
|
| 321 |
#' ) |
|
| 322 |
#' ) |
|
| 323 |
#' if (interactive()) {
|
|
| 324 |
#' shinyApp(app$ui, app$server) |
|
| 325 |
#' } |
|
| 326 |
#' |
|
| 327 |
#' @export |
|
| 328 |
tm_t_mult_events <- function(label, |
|
| 329 |
dataname, |
|
| 330 |
parentname = ifelse( |
|
| 331 |
inherits(arm_var, "data_extract_spec"), |
|
| 332 |
teal.transform::datanames_input(arm_var), |
|
| 333 |
"ADSL" |
|
| 334 |
), |
|
| 335 |
arm_var, |
|
| 336 |
seq_var, |
|
| 337 |
hlt, |
|
| 338 |
llt, |
|
| 339 |
add_total = TRUE, |
|
| 340 |
total_label = default_total_label(), |
|
| 341 |
na_level = default_na_str(), |
|
| 342 |
event_type = "event", |
|
| 343 |
drop_arm_levels = TRUE, |
|
| 344 |
pre_output = NULL, |
|
| 345 |
post_output = NULL, |
|
| 346 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 347 | ! |
message("Initializing tm_t_mult_events")
|
| 348 | ! |
checkmate::assert_string(label) |
| 349 | ! |
checkmate::assert_string(dataname) |
| 350 | ! |
checkmate::assert_string(parentname) |
| 351 | ! |
checkmate::assert_class(arm_var, "choices_selected") |
| 352 | ! |
checkmate::assert_class(seq_var, "choices_selected") |
| 353 | ! |
checkmate::assert_class(hlt, "choices_selected") |
| 354 | ! |
checkmate::assert_class(llt, "choices_selected") |
| 355 | ! |
checkmate::assert_string(event_type) |
| 356 | ! |
checkmate::assert_flag(add_total) |
| 357 | ! |
checkmate::assert_string(total_label) |
| 358 | ! |
checkmate::assert_string(na_level) |
| 359 | ! |
checkmate::assert_flag(drop_arm_levels) |
| 360 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 361 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 362 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 363 | ||
| 364 | ! |
args <- as.list(environment()) |
| 365 | ||
| 366 | ! |
data_extract_list <- list( |
| 367 | ! |
arm_var = cs_to_des_select(arm_var, dataname = parentname), |
| 368 | ! |
seq_var = cs_to_des_select(seq_var, dataname = dataname), |
| 369 | ! |
hlt = cs_to_des_select(hlt, dataname = dataname, multiple = TRUE, ordered = TRUE), |
| 370 | ! |
llt = cs_to_des_select(llt, dataname = dataname) |
| 371 |
) |
|
| 372 | ||
| 373 | ! |
module( |
| 374 | ! |
label = label, |
| 375 | ! |
ui = ui_t_mult_events_byterm, |
| 376 | ! |
server = srv_t_mult_events_byterm, |
| 377 | ! |
ui_args = c(data_extract_list, args), |
| 378 | ! |
server_args = c( |
| 379 | ! |
data_extract_list, |
| 380 | ! |
list( |
| 381 | ! |
dataname = dataname, |
| 382 | ! |
parentname = parentname, |
| 383 | ! |
event_type = event_type, |
| 384 | ! |
label = label, |
| 385 | ! |
total_label = total_label, |
| 386 | ! |
na_level = na_level, |
| 387 | ! |
basic_table_args = basic_table_args |
| 388 |
) |
|
| 389 |
), |
|
| 390 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 391 |
) |
|
| 392 |
} |
|
| 393 | ||
| 394 |
#' @keywords internal |
|
| 395 |
ui_t_mult_events_byterm <- function(id, ...) {
|
|
| 396 | ! |
ns <- NS(id) |
| 397 | ! |
a <- list(...) |
| 398 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset(a$arm_var, a$seq_var, a$hlt, a$llt) |
| 399 | ||
| 400 | ! |
teal.widgets::standard_layout( |
| 401 | ! |
output = teal.widgets::white_small_well( |
| 402 | ! |
teal.widgets::table_with_settings_ui(ns("table"))
|
| 403 |
), |
|
| 404 | ! |
encoding = tags$div( |
| 405 |
### Reporter |
|
| 406 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 407 |
### |
|
| 408 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 409 | ! |
teal.transform::datanames_input(a[c("arm_var", "seq_var", "hlt", "llt")]),
|
| 410 | ! |
teal.transform::data_extract_ui( |
| 411 | ! |
id = ns("arm_var"),
|
| 412 | ! |
label = "Select Treatment Variable", |
| 413 | ! |
data_extract_spec = a$arm_var, |
| 414 | ! |
is_single_dataset = is_single_dataset_value |
| 415 |
), |
|
| 416 | ! |
teal.transform::data_extract_ui( |
| 417 | ! |
id = ns("hlt"),
|
| 418 | ! |
label = "Event High Level Term", |
| 419 | ! |
data_extract_spec = a$hlt, |
| 420 | ! |
is_single_dataset = is_single_dataset_value |
| 421 |
), |
|
| 422 | ! |
teal.transform::data_extract_ui( |
| 423 | ! |
id = ns("llt"),
|
| 424 | ! |
label = "Event Low Level Term", |
| 425 | ! |
data_extract_spec = a$llt, |
| 426 | ! |
is_single_dataset = is_single_dataset_value |
| 427 |
), |
|
| 428 | ! |
checkboxInput(ns("add_total"), "Add All Patients columns", value = a$add_total),
|
| 429 | ! |
teal.widgets::panel_group( |
| 430 | ! |
teal.widgets::panel_item( |
| 431 | ! |
"Additional table settings", |
| 432 | ! |
checkboxInput( |
| 433 | ! |
ns("drop_arm_levels"),
|
| 434 | ! |
label = "Drop columns not in filtered analysis dataset", |
| 435 | ! |
value = a$drop_arm_levels |
| 436 |
) |
|
| 437 |
) |
|
| 438 |
), |
|
| 439 | ! |
teal.widgets::panel_group( |
| 440 | ! |
teal.widgets::panel_item( |
| 441 | ! |
"Additional Variables Info", |
| 442 | ! |
teal.transform::data_extract_ui( |
| 443 | ! |
id = ns("seq_var"),
|
| 444 | ! |
label = "Analysis Sequence Number", |
| 445 | ! |
data_extract_spec = a$seq_var, |
| 446 | ! |
is_single_dataset = is_single_dataset_value |
| 447 |
) |
|
| 448 |
) |
|
| 449 |
) |
|
| 450 |
), |
|
| 451 | ! |
forms = tagList( |
| 452 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 453 |
), |
|
| 454 | ! |
pre_output = a$pre_output, |
| 455 | ! |
post_output = a$post_output |
| 456 |
) |
|
| 457 |
} |
|
| 458 | ||
| 459 |
#' @keywords internal |
|
| 460 |
srv_t_mult_events_byterm <- function(id, |
|
| 461 |
data, |
|
| 462 |
reporter, |
|
| 463 |
filter_panel_api, |
|
| 464 |
dataname, |
|
| 465 |
parentname, |
|
| 466 |
event_type, |
|
| 467 |
arm_var, |
|
| 468 |
seq_var, |
|
| 469 |
hlt, |
|
| 470 |
llt, |
|
| 471 |
drop_arm_levels, |
|
| 472 |
label, |
|
| 473 |
total_label, |
|
| 474 |
na_level, |
|
| 475 |
basic_table_args) {
|
|
| 476 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 477 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 478 | ! |
checkmate::assert_class(data, "reactive") |
| 479 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 480 | ||
| 481 | ! |
moduleServer(id, function(input, output, session) {
|
| 482 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 483 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 484 | ! |
data_extract = list( |
| 485 | ! |
arm_var = arm_var, |
| 486 | ! |
seq_var = seq_var, |
| 487 | ! |
hlt = hlt, |
| 488 | ! |
llt = llt |
| 489 |
), |
|
| 490 | ! |
datasets = data, |
| 491 | ! |
select_validation_rule = list( |
| 492 | ! |
arm_var = shinyvalidate::sv_required("Please select a treatment variable"),
|
| 493 | ! |
llt = shinyvalidate::sv_required("Please select a \"LOW LEVEL TERM\" variable")
|
| 494 |
) |
|
| 495 |
) |
|
| 496 | ||
| 497 | ! |
iv_r <- reactive({
|
| 498 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 499 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list, c("arm_var", "llt"))
|
| 500 |
}) |
|
| 501 | ||
| 502 | ! |
anl_merge_inputs <- teal.transform::merge_expression_srv( |
| 503 | ! |
id = "anl_merge", |
| 504 | ! |
datasets = data, |
| 505 | ! |
selector_list = selector_list, |
| 506 | ! |
merge_function = "dplyr::inner_join" |
| 507 |
) |
|
| 508 | ||
| 509 | ! |
adsl_merge_inputs <- teal.transform::merge_expression_module( |
| 510 | ! |
id = "adsl_merge", |
| 511 | ! |
datasets = data, |
| 512 | ! |
data_extract = list(arm_var = arm_var), |
| 513 | ! |
anl_name = "ANL_ADSL" |
| 514 |
) |
|
| 515 | ||
| 516 | ! |
anl_q <- reactive({
|
| 517 | ! |
data() %>% |
| 518 | ! |
teal.code::eval_code(as.expression(anl_merge_inputs()$expr)) %>% |
| 519 | ! |
teal.code::eval_code(as.expression(adsl_merge_inputs()$expr)) |
| 520 |
}) |
|
| 521 | ||
| 522 | ! |
validate_checks <- reactive({
|
| 523 | ! |
teal::validate_inputs(iv_r()) |
| 524 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 525 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 526 | ||
| 527 | ! |
anl_m <- anl_merge_inputs() |
| 528 | ! |
input_arm_var <- as.vector(anl_m$columns_source$arm_var) |
| 529 | ! |
input_seq_var <- as.vector(anl_m$columns_source$seq_var) |
| 530 | ||
| 531 | ! |
input_hlt <- as.vector(anl_m$columns_source$hlt) |
| 532 | ! |
input_llt <- as.vector(anl_m$columns_source$llt) |
| 533 | ||
| 534 | ||
| 535 | ! |
validate( |
| 536 | ! |
need(is.factor(adsl_filtered[[input_arm_var]]), "Treatment variable is not a factor.") |
| 537 |
) |
|
| 538 | ! |
validate( |
| 539 | ! |
need(is.integer(anl_filtered[[input_seq_var]]), "Analysis sequence variable is not an integer.") |
| 540 |
) |
|
| 541 | ||
| 542 |
# validate inputs |
|
| 543 | ! |
validate_standard_inputs( |
| 544 | ! |
adsl = adsl_filtered, |
| 545 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 546 | ! |
anl = anl_filtered, |
| 547 | ! |
anlvars = c("USUBJID", "STUDYID", input_seq_var, input_hlt, input_llt),
|
| 548 | ! |
arm_var = input_arm_var |
| 549 |
) |
|
| 550 |
}) |
|
| 551 | ||
| 552 |
# The R-code corresponding to the analysis. |
|
| 553 | ! |
all_q <- reactive({
|
| 554 | ! |
validate_checks() |
| 555 | ||
| 556 | ! |
anl_q <- anl_q() |
| 557 | ! |
anl_m <- anl_merge_inputs() |
| 558 | ||
| 559 | ! |
input_hlt <- names(anl_m$columns_source$hlt) |
| 560 | ! |
input_llt <- names(anl_m$columns_source$llt) |
| 561 | ||
| 562 | ! |
hlt_labels <- mapply(function(x) rtables::obj_label(anl_q[["ANL"]][[x]]), input_hlt) |
| 563 | ! |
llt_labels <- mapply(function(x) rtables::obj_label(anl_q[["ANL"]][[x]]), input_llt) |
| 564 | ||
| 565 | ! |
basic_table_args$title <- ifelse( |
| 566 | ! |
is.null(basic_table_args$title), |
| 567 | ! |
paste( |
| 568 | ! |
"Concomitant Medications by", |
| 569 | ! |
paste(hlt_labels, collapse = ", "), |
| 570 | ! |
"and", |
| 571 | ! |
paste(llt_labels, collapse = ", ") |
| 572 |
), |
|
| 573 | ! |
basic_table_args$title |
| 574 |
) |
|
| 575 | ||
| 576 | ! |
my_calls <- template_mult_events( |
| 577 | ! |
dataname = "ANL", |
| 578 | ! |
parentname = "ANL_ADSL", |
| 579 | ! |
arm_var = names(anl_m$columns_source$arm_var), |
| 580 | ! |
seq_var = names(anl_m$columns_source$seq_var), |
| 581 | ! |
hlt = if (length(input_hlt) != 0) input_hlt else NULL, |
| 582 | ! |
llt = input_llt, |
| 583 | ! |
add_total = input$add_total, |
| 584 | ! |
total_label = total_label, |
| 585 | ! |
na_level = na_level, |
| 586 | ! |
event_type = event_type, |
| 587 | ! |
drop_arm_levels = input$drop_arm_levels, |
| 588 | ! |
basic_table_args = basic_table_args |
| 589 |
) |
|
| 590 | ! |
teal.code::eval_code(anl_q, as.expression(my_calls)) |
| 591 |
}) |
|
| 592 | ||
| 593 |
# Outputs to render. |
|
| 594 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 595 | ||
| 596 | ! |
teal.widgets::table_with_settings_srv(id = "table", table_r = table_r) |
| 597 | ||
| 598 |
# Render R code. |
|
| 599 | ! |
teal.widgets::verbatim_popup_srv( |
| 600 | ! |
id = "rcode", |
| 601 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 602 | ! |
title = label |
| 603 |
) |
|
| 604 | ||
| 605 |
### REPORTER |
|
| 606 | ! |
if (with_reporter) {
|
| 607 | ! |
card_fun <- function(comment, label) {
|
| 608 | ! |
card <- teal::report_card_template( |
| 609 | ! |
title = "Multiple Events by Term Table", |
| 610 | ! |
label = label, |
| 611 | ! |
with_filter = with_filter, |
| 612 | ! |
filter_panel_api = filter_panel_api |
| 613 |
) |
|
| 614 | ! |
card$append_text("Table", "header3")
|
| 615 | ! |
card$append_table(table_r()) |
| 616 | ! |
if (!comment == "") {
|
| 617 | ! |
card$append_text("Comment", "header3")
|
| 618 | ! |
card$append_text(comment) |
| 619 |
} |
|
| 620 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 621 | ! |
card |
| 622 |
} |
|
| 623 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 624 |
} |
|
| 625 |
### |
|
| 626 |
}) |
|
| 627 |
} |
| 1 |
#' Concatenate expressions via a binary operator |
|
| 2 |
#' |
|
| 3 |
#' e.g. combine with `+` for `ggplot` without introducing parentheses due to associativity |
|
| 4 |
#' |
|
| 5 |
#' @param args arguments to concatenate with operator |
|
| 6 |
#' @param bin_op binary operator to concatenate it with |
|
| 7 |
#' |
|
| 8 |
#' @return a `call` |
|
| 9 |
#' |
|
| 10 |
#' @examples |
|
| 11 |
#' library(ggplot2) |
|
| 12 |
#' |
|
| 13 |
#' # What we want to achieve |
|
| 14 |
#' call("+", quote(f), quote(g))
|
|
| 15 |
#' call("+", quote(f), call("+", quote(g), quote(h))) # parentheses not wanted
|
|
| 16 |
#' call("+", call("+", quote(f), quote(g)), quote(h)) # as expected without unnecessary parentheses
|
|
| 17 |
#' Reduce(function(existing, new) call("+", existing, new), list(quote(f), quote(g), quote(h)))
|
|
| 18 |
#' |
|
| 19 |
#' # how we do it |
|
| 20 |
#' call_concatenate(list(quote(f), quote(g), quote(h))) |
|
| 21 |
#' call_concatenate(list(quote(f))) |
|
| 22 |
#' call_concatenate(list()) |
|
| 23 |
#' call_concatenate( |
|
| 24 |
#' list(quote(ggplot(mtcars)), quote(geom_point(aes(wt, mpg)))) |
|
| 25 |
#' ) |
|
| 26 |
#' |
|
| 27 |
#' eval( |
|
| 28 |
#' call_concatenate( |
|
| 29 |
#' list(quote(ggplot(mtcars)), quote(geom_point(aes(wt, mpg)))) |
|
| 30 |
#' ) |
|
| 31 |
#' ) |
|
| 32 |
#' |
|
| 33 |
#' @export |
|
| 34 |
call_concatenate <- function(args, bin_op = "+") {
|
|
| 35 | ! |
checkmate::assert_string(bin_op) |
| 36 | ! |
checkmate::assert_list(args, types = c("symbol", "name", "call", "expression"))
|
| 37 | ||
| 38 |
# can be used for dplyr and ggplot2 to concatenate calls with + |
|
| 39 | ! |
Reduce(function(existing, new) call(bin_op, existing, new), args) |
| 40 |
} |
|
| 41 | ||
| 42 |
# needs columns like n_, n_ARM etc. to get count from |
|
| 43 |
count_str_to_column_expr <- function(column, n_column = get_n_name(groupby_vars = column)) {
|
|
| 44 | ! |
checkmate::assert_string(column) |
| 45 | ||
| 46 | ! |
substitute_names( |
| 47 | ! |
expr = counts <- counts %>% dplyr::mutate( |
| 48 | ! |
column_name = paste0(column_name, " (n = ", n_column_name, ")") |
| 49 |
), |
|
| 50 | ! |
names = list(column_name = as.symbol(column), n_column_name = as.symbol(n_column)) |
| 51 |
) |
|
| 52 |
} |
|
| 53 | ||
| 54 |
#' Get variable labels |
|
| 55 |
#' |
|
| 56 |
#' @description `r lifecycle::badge("deprecated")`
|
|
| 57 |
#' @param datasets (`teal::FilteredData`)\cr Data built up by teal |
|
| 58 |
#' @param dataname (`character`)\cr name of the dataset |
|
| 59 |
#' @param vars (`character`)\cr Column names in the data |
|
| 60 |
#' |
|
| 61 |
#' @return `character` variable labels. |
|
| 62 |
#' |
|
| 63 |
#' @export |
|
| 64 |
get_var_labels <- function(datasets, dataname, vars) {
|
|
| 65 | ! |
lifecycle::deprecate_warn( |
| 66 | ! |
when = "0.8.14", |
| 67 | ! |
what = "get_var_labels()", |
| 68 | ! |
with = "teal.data::col_labels()", |
| 69 | ! |
details = "teal.modules.clinical won't export any utility functions except those which |
| 70 | ! |
are necessary to prepare shiny app." |
| 71 |
) |
|
| 72 | ! |
labels <- datasets$get_varlabels(dataname, vars) |
| 73 | ! |
labels <- vapply(vars, function(x) ifelse(is.na(labels[[x]]), x, labels[[x]]), character(1)) |
| 74 | ! |
return(labels) |
| 75 |
} |
|
| 76 | ||
| 77 |
#' Expression Deparsing |
|
| 78 |
#' |
|
| 79 |
#' Deparse an expression into a `string`. |
|
| 80 |
#' |
|
| 81 |
#' @param expr (`call`)\cr or an object which can be used as so. |
|
| 82 |
#' |
|
| 83 |
#' @return a `string`. |
|
| 84 |
#' |
|
| 85 |
#' @export |
|
| 86 |
#' @examples |
|
| 87 |
#' expr <- quote({
|
|
| 88 |
#' library(rtables) |
|
| 89 |
#' basic_table() %>% |
|
| 90 |
#' split_cols_by(var = "ARMCD") %>% |
|
| 91 |
#' test_proportion_diff( |
|
| 92 |
#' vars = "rsp", method = "cmh", variables = list(strata = "strata") |
|
| 93 |
#' ) %>% |
|
| 94 |
#' build_table(df = dta) |
|
| 95 |
#' }) |
|
| 96 |
#' |
|
| 97 |
#' h_concat_expr(expr) |
|
| 98 |
h_concat_expr <- function(expr) {
|
|
| 99 | 716x |
expr <- deparse(expr) |
| 100 | 716x |
paste(expr, collapse = "\n") |
| 101 |
} |
|
| 102 | ||
| 103 | ||
| 104 |
#' Expressions as a Pipeline |
|
| 105 |
#' |
|
| 106 |
#' Concatenate expressions in a single pipeline-flavor expression. |
|
| 107 |
#' |
|
| 108 |
#' @param exprs (`list` of `call`)\cr expressions to concatenate in a |
|
| 109 |
#' pipeline (`%>%`). |
|
| 110 |
#' @param pipe_str (`character`)\cr the character which separates the expressions. |
|
| 111 |
#' |
|
| 112 |
#' @return a `call` |
|
| 113 |
#' |
|
| 114 |
#' @examples |
|
| 115 |
#' pipe_expr( |
|
| 116 |
#' list( |
|
| 117 |
#' expr1 = substitute(df), |
|
| 118 |
#' expr2 = substitute(head) |
|
| 119 |
#' ) |
|
| 120 |
#' ) |
|
| 121 |
#' |
|
| 122 |
#' @export |
|
| 123 |
pipe_expr <- function(exprs, pipe_str = "%>%") {
|
|
| 124 | 210x |
exprs <- lapply(exprs, h_concat_expr) |
| 125 | 210x |
exprs <- unlist(exprs) |
| 126 | 210x |
exprs <- paste(exprs, collapse = pipe_str) |
| 127 | 210x |
str2lang(exprs) |
| 128 |
} |
|
| 129 | ||
| 130 |
#' Expression List |
|
| 131 |
#' |
|
| 132 |
#' Add a new expression to a list (of expressions). |
|
| 133 |
#' |
|
| 134 |
#' @param expr_ls (`list` of `call`)\cr the list to which a new expression |
|
| 135 |
#' should be added. |
|
| 136 |
#' @param new_expr (`call`)\cr the new expression to add. |
|
| 137 |
#' |
|
| 138 |
#' @return a `list` of `call`. |
|
| 139 |
#' |
|
| 140 |
#' @details Offers a stricter control to add new expressions to an existing |
|
| 141 |
#' list. The list of expressions can be later used to generate a pipeline, |
|
| 142 |
#' for instance with `pipe_expr`. |
|
| 143 |
#' |
|
| 144 |
#' @export |
|
| 145 |
#' |
|
| 146 |
#' @examples |
|
| 147 |
#' library(rtables) |
|
| 148 |
#' |
|
| 149 |
#' lyt <- list() |
|
| 150 |
#' lyt <- add_expr(lyt, substitute(basic_table())) |
|
| 151 |
#' lyt <- add_expr( |
|
| 152 |
#' lyt, substitute(split_cols_by(var = arm), env = list(armcd = "ARMCD")) |
|
| 153 |
#' ) |
|
| 154 |
#' lyt <- add_expr( |
|
| 155 |
#' lyt, |
|
| 156 |
#' substitute( |
|
| 157 |
#' test_proportion_diff( |
|
| 158 |
#' vars = "rsp", method = "cmh", variables = list(strata = "strata") |
|
| 159 |
#' ) |
|
| 160 |
#' ) |
|
| 161 |
#' ) |
|
| 162 |
#' lyt <- add_expr(lyt, quote(build_table(df = dta))) |
|
| 163 |
#' pipe_expr(lyt) |
|
| 164 |
add_expr <- function(expr_ls, new_expr) {
|
|
| 165 | 1676x |
checkmate::assert_list(expr_ls) |
| 166 | 1676x |
checkmate::assert(is.call(new_expr) || is.name(new_expr)) |
| 167 | ||
| 168 |
# support nested expressions such as expr({a <- 1; b <- 2})
|
|
| 169 | 1676x |
if (inherits(new_expr, "{")) {
|
| 170 | 105x |
res <- expr_ls |
| 171 | 105x |
for (idx in seq_along(new_expr)[-1]) {
|
| 172 | 312x |
res <- add_expr(res, new_expr[[idx]]) |
| 173 |
} |
|
| 174 | 105x |
return(res) |
| 175 |
} |
|
| 176 | ||
| 177 | 1571x |
c( |
| 178 | 1571x |
expr_ls, |
| 179 | 1571x |
list(new_expr) |
| 180 |
) |
|
| 181 |
} |
|
| 182 | ||
| 183 | ||
| 184 |
#' Expressions in Brackets |
|
| 185 |
#' |
|
| 186 |
#' Groups several expressions in a single _bracketed_ expression. |
|
| 187 |
#' |
|
| 188 |
#' @param exprs (`list` of `call`)\cr expressions to concatenate into |
|
| 189 |
#' a single _bracketed_ expression. |
|
| 190 |
#' |
|
| 191 |
#' @return a `{` object. See [base::Paren()] for details.
|
|
| 192 |
#' |
|
| 193 |
#' @examples |
|
| 194 |
#' adsl <- tmc_ex_adsl |
|
| 195 |
#' adrs <- tmc_ex_adrs |
|
| 196 |
#' |
|
| 197 |
#' expr1 <- substitute( |
|
| 198 |
#' expr = anl <- subset(df, PARAMCD == param), |
|
| 199 |
#' env = list(df = as.name("adrs"), param = "INVET")
|
|
| 200 |
#' ) |
|
| 201 |
#' expr2 <- substitute(expr = anl$rsp_lab <- d_onco_rsp_label(anl$AVALC)) |
|
| 202 |
#' expr3 <- substitute( |
|
| 203 |
#' expr = {
|
|
| 204 |
#' anl$is_rsp <- anl$rsp_lab %in% |
|
| 205 |
#' c("Complete Response (CR)", "Partial Response (PR)")
|
|
| 206 |
#' } |
|
| 207 |
#' ) |
|
| 208 |
#' |
|
| 209 |
#' res <- bracket_expr(list(expr1, expr2, expr3)) |
|
| 210 |
#' eval(res) |
|
| 211 |
#' table(anl$rsp_lab, anl$is_rsp) |
|
| 212 |
#' |
|
| 213 |
#' @export |
|
| 214 |
bracket_expr <- function(exprs) {
|
|
| 215 | 196x |
expr <- lapply(exprs, deparse) |
| 216 | ||
| 217 |
# Because `deparse` returns a vector accounting for line break attempted |
|
| 218 |
# for string longer than max `width.cutoff = 500`. |
|
| 219 | 196x |
expr <- lapply(expr, paste, collapse = "\n") |
| 220 | ||
| 221 | 196x |
expr <- paste( |
| 222 | 196x |
c( |
| 223 |
"{",
|
|
| 224 | 196x |
unlist(expr), |
| 225 |
"}" |
|
| 226 |
), |
|
| 227 | 196x |
collapse = "\n" |
| 228 |
) |
|
| 229 | 196x |
expr <- parse(text = expr, keep.source = FALSE) |
| 230 | 196x |
expr <- as.call(expr)[[1]] |
| 231 | 196x |
attributes(expr) <- NULL |
| 232 | 196x |
expr |
| 233 |
} |
|
| 234 | ||
| 235 |
#' Convert choices_selected to select_spec |
|
| 236 |
#' |
|
| 237 |
#' @param cs (`choices_selected`)\cr object to be transformed. See [teal.transform::choices_selected()] for details. |
|
| 238 |
#' @param multiple (`logical`)\cr Whether multiple values shall be allowed in the |
|
| 239 |
#' shiny [shiny::selectInput()]. |
|
| 240 |
#' @param ordered (`logical(1)`)\cr Flags whether selection order should be tracked. |
|
| 241 |
#' @param label (`character`)\cr Label to print over the selection field. For no label, set to `NULL`. |
|
| 242 |
#' @export |
|
| 243 |
#' @return (`select_spec`) |
|
| 244 |
cs_to_select_spec <- function(cs, multiple = FALSE, ordered = FALSE, label = "Select") {
|
|
| 245 | 9x |
checkmate::assert_class(cs, "choices_selected") |
| 246 | 8x |
checkmate::assert_flag(multiple) |
| 247 | 7x |
checkmate::assert_flag(ordered) |
| 248 | ||
| 249 | 6x |
teal.transform::select_spec( |
| 250 | 6x |
choices = cs$choices, |
| 251 | 6x |
selected = cs$selected, |
| 252 | 6x |
fixed = cs$fixed, |
| 253 | 6x |
multiple = multiple, |
| 254 | 6x |
ordered = ordered, |
| 255 | 6x |
label = label |
| 256 |
) |
|
| 257 |
} |
|
| 258 | ||
| 259 |
#' Convert choices_selected to filter_spec |
|
| 260 |
#' |
|
| 261 |
#' @inheritParams cs_to_select_spec |
|
| 262 |
#' |
|
| 263 |
#' @export |
|
| 264 |
#' @return ([teal.transform::filter_spec()]) |
|
| 265 |
cs_to_filter_spec <- function(cs, multiple = FALSE, label = "Filter by") {
|
|
| 266 | 2x |
checkmate::assert_class(cs, "choices_selected") |
| 267 | 2x |
checkmate::assert_flag(multiple) |
| 268 | ||
| 269 | 2x |
vars <- if (inherits(cs, "delayed_choices_selected")) {
|
| 270 | ! |
cs$choices$var_choices |
| 271 |
} else {
|
|
| 272 | 2x |
attr(cs$choices, "var_choices") |
| 273 |
} |
|
| 274 | ||
| 275 | 2x |
teal.transform::filter_spec( |
| 276 | 2x |
vars = vars, |
| 277 | 2x |
choices = cs$choices, |
| 278 | 2x |
selected = cs$selected, |
| 279 | 2x |
multiple = multiple, |
| 280 | 2x |
drop_keys = FALSE, |
| 281 | 2x |
label = label |
| 282 |
) |
|
| 283 |
} |
|
| 284 | ||
| 285 |
#' Convert choices_selected to data_extract_spec with only select_spec |
|
| 286 |
#' |
|
| 287 |
#' @inheritParams cs_to_select_spec |
|
| 288 |
#' @param dataname (`character`)\cr name of the data |
|
| 289 |
#' |
|
| 290 |
#' @export |
|
| 291 |
#' @return ([teal.transform::data_extract_spec()]) |
|
| 292 |
cs_to_des_select <- function(cs, dataname, multiple = FALSE, ordered = FALSE, label = "Select") {
|
|
| 293 | 4x |
cs_sub <- substitute(cs) |
| 294 | 4x |
cs_name <- if (is.symbol(cs_sub)) as.character(cs_sub) else "cs" |
| 295 | ||
| 296 | 4x |
checkmate::assert_string(dataname) |
| 297 | 4x |
checkmate::assert_flag(multiple) |
| 298 | 4x |
checkmate::assert( |
| 299 | 4x |
checkmate::check_class(cs, classes = "data_extract_spec"), |
| 300 | 4x |
checkmate::check_class(cs, classes = "choices_selected"), |
| 301 | 4x |
.var.name = cs_name |
| 302 |
) |
|
| 303 | 4x |
if (!multiple && length(cs$selected) != 1 && !is.null(cs$selected)) {
|
| 304 | ! |
stop(cs_name, "must only have 1 selected value") |
| 305 |
} |
|
| 306 | ||
| 307 | 4x |
if (inherits(cs, "choices_selected")) {
|
| 308 | 3x |
teal.transform::data_extract_spec( |
| 309 | 3x |
dataname = dataname, |
| 310 | 3x |
select = cs_to_select_spec(cs, multiple = multiple, ordered = ordered, label = label) |
| 311 |
) |
|
| 312 |
} else {
|
|
| 313 | 1x |
return(cs) |
| 314 |
} |
|
| 315 |
} |
|
| 316 | ||
| 317 |
#' Convert choices_selected to data_extract_spec with only filter_spec |
|
| 318 |
#' |
|
| 319 |
#' @inheritParams cs_to_des_select |
|
| 320 |
#' @param include_vars (`flag`)\cr whether to include the filter variables as fixed selection |
|
| 321 |
#' in the result. This can be useful for preserving for reuse in `rtables` code e.g. |
|
| 322 |
#' |
|
| 323 |
#' @export |
|
| 324 |
#' @return ([teal.transform::data_extract_spec()]) |
|
| 325 |
cs_to_des_filter <- function(cs, dataname, multiple = FALSE, include_vars = FALSE, label = "Filter by") {
|
|
| 326 | ! |
cs_sub <- substitute(cs) |
| 327 | ! |
cs_name <- if (is.symbol(cs_sub)) as.character(cs_sub) else "cs" |
| 328 | ||
| 329 | ! |
checkmate::assert_string(dataname) |
| 330 | ! |
checkmate::assert_flag(multiple) |
| 331 | ! |
checkmate::assert( |
| 332 | ! |
checkmate::check_class(cs, classes = "data_extract_spec"), |
| 333 | ! |
checkmate::check_class(cs, classes = "choices_selected"), |
| 334 | ! |
.var.name = cs_name |
| 335 |
) |
|
| 336 | ! |
if (!multiple && length(cs$selected) != 1 && !is.null(cs$selected)) {
|
| 337 | ! |
stop(cs_name, "must only have 1 selected value") |
| 338 |
} |
|
| 339 | ||
| 340 | ! |
if (inherits(cs, "choices_selected")) {
|
| 341 | ! |
vars <- if (inherits(cs, "delayed_choices_selected")) {
|
| 342 | ! |
cs$choices$var_choices |
| 343 |
} else {
|
|
| 344 | ! |
attr(cs$choices, "var_choices") |
| 345 |
} |
|
| 346 | ! |
select <- if (include_vars) {
|
| 347 | ! |
teal.transform::select_spec( |
| 348 | ! |
choices = vars, |
| 349 | ! |
selected = vars, |
| 350 | ! |
fixed = TRUE |
| 351 |
) |
|
| 352 |
} else {
|
|
| 353 | ! |
NULL |
| 354 |
} |
|
| 355 | ||
| 356 | ! |
teal.transform::data_extract_spec( |
| 357 | ! |
dataname = dataname, |
| 358 | ! |
filter = cs_to_filter_spec(cs, multiple = multiple, label = label), |
| 359 | ! |
select = select |
| 360 |
) |
|
| 361 |
} else {
|
|
| 362 | ! |
return(cs) |
| 363 |
} |
|
| 364 |
} |
|
| 365 | ||
| 366 |
#' Whether object is of class [teal.transform::choices_selected()] |
|
| 367 |
#' |
|
| 368 |
#' @param x object to be checked |
|
| 369 |
#' |
|
| 370 |
#' @export |
|
| 371 |
#' @return (`logical`) |
|
| 372 |
is.cs_or_des <- function(x) { # nolint: object_name.
|
|
| 373 | ! |
inherits(x, c("data_extract_spec", "choices_selected"))
|
| 374 |
} |
|
| 375 | ||
| 376 |
#' Split-Column Expression |
|
| 377 |
#' |
|
| 378 |
#' Renders the expression for column split in `rtables` depending on: |
|
| 379 |
#' - the expected or not arm comparison |
|
| 380 |
#' - the expected or not arm combination |
|
| 381 |
#' |
|
| 382 |
#' @param compare (`logical`)\cr if `TRUE` the reference level is included. |
|
| 383 |
#' @param combine (`logical`)\cr if `TRUE` the group combination is included. |
|
| 384 |
#' @param ref (`character`)\cr the reference level (not used for `combine = TRUE`). |
|
| 385 |
#' @param arm_var (`character`)\cr the arm or grouping variable name. |
|
| 386 |
#' |
|
| 387 |
#' @return a `call` |
|
| 388 |
#' |
|
| 389 |
#' @examples |
|
| 390 |
#' split_col_expr( |
|
| 391 |
#' compare = TRUE, |
|
| 392 |
#' combine = FALSE, |
|
| 393 |
#' ref = "ARM A", |
|
| 394 |
#' arm_var = "ARMCD" |
|
| 395 |
#' ) |
|
| 396 |
#' |
|
| 397 |
#' @export |
|
| 398 |
split_col_expr <- function(compare, combine, ref, arm_var) {
|
|
| 399 | 15x |
if (compare && combine) {
|
| 400 | 3x |
substitute( |
| 401 | 3x |
expr = split_cols_by_groups( |
| 402 | 3x |
var = arm_var, |
| 403 | 3x |
groups_list = groups, |
| 404 | 3x |
ref_group = names(groups)[1] |
| 405 |
), |
|
| 406 | 3x |
env = list( |
| 407 | 3x |
arm_var = arm_var |
| 408 |
) |
|
| 409 |
) |
|
| 410 | 12x |
} else if (compare && !combine) {
|
| 411 | 6x |
substitute( |
| 412 | 6x |
expr = rtables::split_cols_by( |
| 413 | 6x |
var = arm_var, |
| 414 | 6x |
ref_group = ref |
| 415 |
), |
|
| 416 | 6x |
env = list( |
| 417 | 6x |
arm_var = arm_var, |
| 418 | 6x |
ref = ref |
| 419 |
) |
|
| 420 |
) |
|
| 421 | 6x |
} else if (!compare) {
|
| 422 | 6x |
substitute( |
| 423 | 6x |
expr = rtables::split_cols_by(var = arm_var), |
| 424 | 6x |
env = list(arm_var = arm_var) |
| 425 |
) |
|
| 426 |
} |
|
| 427 |
} |
|
| 428 | ||
| 429 |
#' Split `choices_selected` objects with interactions into |
|
| 430 |
#' their component variables |
|
| 431 |
#' |
|
| 432 |
#' @param x (`choices_selected`)\cr |
|
| 433 |
#' object with interaction terms |
|
| 434 |
#' |
|
| 435 |
#' @note uses the regex `\\*|:` to perform the split. |
|
| 436 |
#' |
|
| 437 |
#' @return a [choices_selected()] object. |
|
| 438 |
#' |
|
| 439 |
#' @examples |
|
| 440 |
#' split_choices(choices_selected(choices = c("x:y", "a*b"), selected = all_choices()))
|
|
| 441 |
#' |
|
| 442 |
#' @export |
|
| 443 |
split_choices <- function(x) {
|
|
| 444 | ! |
checkmate::assert_class(x, "choices_selected") |
| 445 | ! |
checkmate::assert_character(x$choices, min.len = 1) |
| 446 | ||
| 447 | ! |
split_x <- x |
| 448 | ! |
split_x$choices <- split_interactions(x$choices) |
| 449 | ! |
if (!is.null(x$selected)) {
|
| 450 | ! |
split_x$selected <- split_interactions(x$selected) |
| 451 |
} |
|
| 452 | ||
| 453 | ! |
return(split_x) |
| 454 |
} |
|
| 455 | ||
| 456 |
#' Extracts html id for `data_extract_ui` |
|
| 457 |
#' |
|
| 458 |
#' The `data_extract_ui` is located under extended html id. We could not use `ns("original id")`
|
|
| 459 |
#' for reference, as it is extended with specific suffixes. |
|
| 460 |
#' |
|
| 461 |
#' @param varname (`character`)\cr |
|
| 462 |
#' the original html id. This should be retrieved with `ns("original id")` in the UI function
|
|
| 463 |
#' or `session$ns("original id")`/"original id" in the server function.
|
|
| 464 |
#' @param dataname (`character`)\cr |
|
| 465 |
#' `dataname` from data_extract input. |
|
| 466 |
#' This might be retrieved like `data_extract_spec(...)[[1]]$dataname`. |
|
| 467 |
#' @param filter (`logical`) optional,\cr |
|
| 468 |
#' if the connected `extract_data_spec` has objects passed to its `filter` argument |
|
| 469 |
#' |
|
| 470 |
#' @return a string |
|
| 471 |
#' |
|
| 472 |
#' @examples |
|
| 473 |
#' extract_input("ARM", "ADSL")
|
|
| 474 |
#' |
|
| 475 |
#' @export |
|
| 476 |
extract_input <- function(varname, dataname, filter = FALSE) {
|
|
| 477 | ! |
if (filter) {
|
| 478 | ! |
paste0(varname, "-dataset_", dataname, "_singleextract-filter1-vals") |
| 479 |
} else {
|
|
| 480 | ! |
paste0(varname, "-dataset_", dataname, "_singleextract-select") |
| 481 |
} |
|
| 482 |
} |
|
| 483 | ||
| 484 |
#' Split interaction terms into their component variables |
|
| 485 |
#' |
|
| 486 |
#' @param x (`character`)\cr |
|
| 487 |
#' string representing the interaction |
|
| 488 |
#' usually in the form `x:y` or `x*y`. |
|
| 489 |
#' @param by (`character`)\cr |
|
| 490 |
#' regex with which to split the interaction |
|
| 491 |
#' term by. |
|
| 492 |
#' |
|
| 493 |
#' @return a vector of strings where each element is a component |
|
| 494 |
#' variable extracted from interaction term `x`. |
|
| 495 |
#' |
|
| 496 |
#' @examples |
|
| 497 |
#' split_interactions("x:y")
|
|
| 498 |
#' split_interactions("x*y")
|
|
| 499 |
#' |
|
| 500 |
#' @export |
|
| 501 |
split_interactions <- function(x, by = "\\*|:") {
|
|
| 502 | ! |
if (length(x) >= 1) {
|
| 503 | ! |
unique(unlist(strsplit(x, split = by))) |
| 504 |
} else {
|
|
| 505 | ! |
NULL |
| 506 |
} |
|
| 507 |
} |
|
| 508 | ||
| 509 | ||
| 510 |
#' Expression: Arm Preparation |
|
| 511 |
#' |
|
| 512 |
#' The function generate the standard expression for pre-processing of dataset |
|
| 513 |
#' in teal module applications. This is especially of interest when the same |
|
| 514 |
#' preprocessing steps needs to be applied similarly to several datasets |
|
| 515 |
#' (e.g. `ADSL` and `ADRS`). |
|
| 516 |
#' |
|
| 517 |
#' @details |
|
| 518 |
#' In `teal.modules.clinical`, the user interface includes manipulation of |
|
| 519 |
#' the study arms. Classically: the arm variable itself (e.g. `ARM`, `ACTARM`), |
|
| 520 |
#' the reference arm (0 or more), the comparison arm (1 or more) and the |
|
| 521 |
#' possibility to combine comparison arms. |
|
| 522 |
#' |
|
| 523 |
#' Note that when no arms should be compared with each other, then the produced |
|
| 524 |
#' expression is reduced to optionally dropping non-represented levels of the arm. |
|
| 525 |
#' |
|
| 526 |
#' When comparing arms, the pre-processing includes three steps: |
|
| 527 |
#' 1. Filtering of the dataset to retain only the arms of interest (reference |
|
| 528 |
#' and comparison). |
|
| 529 |
#' 2. Optional, if more than one arm is designated as _reference_ they are |
|
| 530 |
#' combined into a single level. |
|
| 531 |
#' 3. The reference is explicitly reassigned and the non-represented levels of |
|
| 532 |
#' arm are dropped. |
|
| 533 |
#' |
|
| 534 |
#' @inheritParams template_arguments |
|
| 535 |
#' @param ref_arm_val (`character`)\cr replacement name for the reference level. |
|
| 536 |
#' @param drop (`logical`)\cr drop the unused variable levels. |
|
| 537 |
#' |
|
| 538 |
#' @return a `call` |
|
| 539 |
#' |
|
| 540 |
#' @examples |
|
| 541 |
#' prepare_arm( |
|
| 542 |
#' dataname = "adrs", |
|
| 543 |
#' arm_var = "ARMCD", |
|
| 544 |
#' ref_arm = "ARM A", |
|
| 545 |
#' comp_arm = c("ARM B", "ARM C")
|
|
| 546 |
#' ) |
|
| 547 |
#' |
|
| 548 |
#' prepare_arm( |
|
| 549 |
#' dataname = "adsl", |
|
| 550 |
#' arm_var = "ARMCD", |
|
| 551 |
#' ref_arm = c("ARM B", "ARM C"),
|
|
| 552 |
#' comp_arm = "ARM A" |
|
| 553 |
#' ) |
|
| 554 |
#' |
|
| 555 |
#' @export |
|
| 556 |
prepare_arm <- function(dataname, |
|
| 557 |
arm_var, |
|
| 558 |
ref_arm, |
|
| 559 |
comp_arm, |
|
| 560 |
compare_arm = !is.null(ref_arm), |
|
| 561 |
ref_arm_val = paste(ref_arm, collapse = "/"), |
|
| 562 |
drop = TRUE) {
|
|
| 563 | 61x |
checkmate::assert_string(dataname) |
| 564 | 61x |
checkmate::assert_string(arm_var) |
| 565 | 61x |
checkmate::assert_character(ref_arm, null.ok = TRUE) |
| 566 | 61x |
checkmate::assert_character(comp_arm, null.ok = TRUE) |
| 567 | 61x |
checkmate::assert_flag(compare_arm) |
| 568 | 61x |
checkmate::assert_string(ref_arm_val) |
| 569 | 61x |
checkmate::assert_flag(drop) |
| 570 | ||
| 571 | 61x |
data_list <- list() |
| 572 | ||
| 573 | 61x |
if (compare_arm) {
|
| 574 |
# Data are filtered to keep only arms of interest. |
|
| 575 | 50x |
data_list <- add_expr( |
| 576 | 50x |
data_list, |
| 577 | 50x |
substitute( |
| 578 | 50x |
expr = dataname %>% |
| 579 | 50x |
dplyr::filter(arm_var %in% arm_val), |
| 580 | 50x |
env = list( |
| 581 | 50x |
dataname = as.name(dataname), |
| 582 | 50x |
arm_var = as.name(arm_var), |
| 583 | 50x |
arm_val = if (compare_arm) c(ref_arm, comp_arm) else comp_arm |
| 584 |
) |
|
| 585 |
) |
|
| 586 |
) |
|
| 587 | ||
| 588 |
# Several reference levels are combined. |
|
| 589 | 50x |
if (length(ref_arm) > 1) {
|
| 590 | 10x |
data_list <- add_expr( |
| 591 | 10x |
data_list, |
| 592 | 10x |
substitute_names( |
| 593 | 10x |
expr = dplyr::mutate(arm_var = combine_levels(arm_var, levels = ref_arm, new_level = ref_arm_val)), |
| 594 | 10x |
names = list(arm_var = as.name(arm_var)), |
| 595 | 10x |
others = list(ref_arm = ref_arm, ref_arm_val = ref_arm_val) |
| 596 |
) |
|
| 597 |
) |
|
| 598 |
} |
|
| 599 | ||
| 600 |
# Reference level is explicit. |
|
| 601 | 50x |
data_list <- add_expr( |
| 602 | 50x |
data_list, |
| 603 | 50x |
substitute_names( |
| 604 | 50x |
expr = dplyr::mutate(arm_var = stats::relevel(arm_var, ref = ref_arm_val)), |
| 605 | 50x |
names = list(arm_var = as.name(arm_var)), |
| 606 | 50x |
others = list(ref_arm_val = ref_arm_val) |
| 607 |
) |
|
| 608 |
) |
|
| 609 |
} else {
|
|
| 610 | 11x |
data_list <- add_expr( |
| 611 | 11x |
data_list, |
| 612 | 11x |
substitute( |
| 613 | 11x |
expr = dataname, |
| 614 | 11x |
env = list(dataname = as.name(dataname)) |
| 615 |
) |
|
| 616 |
) |
|
| 617 |
} |
|
| 618 | ||
| 619 |
# Unused levels are optionally dropped. |
|
| 620 | 61x |
if (drop) {
|
| 621 | 45x |
data_list <- add_expr( |
| 622 | 45x |
data_list, |
| 623 | 45x |
substitute_names( |
| 624 | 45x |
expr = dplyr::mutate(arm_var = droplevels(arm_var)), |
| 625 | 45x |
names = list(arm_var = as.name(arm_var)) |
| 626 |
) |
|
| 627 |
) |
|
| 628 |
} |
|
| 629 | ||
| 630 | 61x |
pipe_expr(data_list) |
| 631 |
} |
|
| 632 | ||
| 633 |
#' Expression: Prepare Arm Levels |
|
| 634 |
#' |
|
| 635 |
#' This function generates the standard expression for pre-processing of dataset |
|
| 636 |
#' arm levels in and is used to apply the same steps in safety teal modules. |
|
| 637 |
#' |
|
| 638 |
#' @inheritParams template_arguments |
|
| 639 |
#' |
|
| 640 |
#' @return a `{` object. See [base::Paren()] for details.
|
|
| 641 |
#' |
|
| 642 |
#' @examples |
|
| 643 |
#' prepare_arm_levels( |
|
| 644 |
#' dataname = "adae", |
|
| 645 |
#' parentname = "adsl", |
|
| 646 |
#' arm_var = "ARMCD", |
|
| 647 |
#' drop_arm_levels = TRUE |
|
| 648 |
#' ) |
|
| 649 |
#' |
|
| 650 |
#' prepare_arm_levels( |
|
| 651 |
#' dataname = "adae", |
|
| 652 |
#' parentname = "adsl", |
|
| 653 |
#' arm_var = "ARMCD", |
|
| 654 |
#' drop_arm_levels = FALSE |
|
| 655 |
#' ) |
|
| 656 |
#' |
|
| 657 |
#' @export |
|
| 658 |
prepare_arm_levels <- function(dataname, |
|
| 659 |
parentname, |
|
| 660 |
arm_var, |
|
| 661 |
drop_arm_levels = TRUE) {
|
|
| 662 | 57x |
checkmate::assert_string(dataname) |
| 663 | 57x |
checkmate::assert_string(parentname) |
| 664 | 57x |
checkmate::assert_string(arm_var) |
| 665 | 57x |
checkmate::assert_flag(drop_arm_levels) |
| 666 | ||
| 667 | 57x |
data_list <- list() |
| 668 | ||
| 669 | 57x |
if (drop_arm_levels) {
|
| 670 |
# Keep only levels that exist in `dataname` dataset |
|
| 671 | 43x |
data_list <- add_expr( |
| 672 | 43x |
data_list, |
| 673 | 43x |
substitute_names( |
| 674 | 43x |
expr = dataname <- dataname %>% dplyr::mutate( |
| 675 | 43x |
arm_var = droplevels(arm_var) |
| 676 |
), |
|
| 677 | 43x |
names = list( |
| 678 | 43x |
dataname = as.name(dataname), |
| 679 | 43x |
arm_var = as.name(arm_var) |
| 680 |
) |
|
| 681 |
) |
|
| 682 |
) |
|
| 683 | ||
| 684 | 43x |
data_list <- add_expr( |
| 685 | 43x |
data_list, |
| 686 | 43x |
substitute( |
| 687 | 43x |
expr = arm_levels <- levels(dataname[[arm_var]]), |
| 688 | 43x |
env = list( |
| 689 | 43x |
dataname = as.name(dataname), |
| 690 | 43x |
arm_var = arm_var |
| 691 |
) |
|
| 692 |
) |
|
| 693 |
) |
|
| 694 | ||
| 695 |
# Data are filtered to keep only arms of interest. |
|
| 696 | 43x |
data_list <- add_expr( |
| 697 | 43x |
data_list, |
| 698 | 43x |
substitute( |
| 699 | 43x |
expr = parentname <- parentname %>% |
| 700 | 43x |
dplyr::filter(arm_var %in% arm_levels), |
| 701 | 43x |
env = list( |
| 702 | 43x |
parentname = as.name(parentname), |
| 703 | 43x |
arm_var = as.name(arm_var) |
| 704 |
) |
|
| 705 |
) |
|
| 706 |
) |
|
| 707 | ||
| 708 | 43x |
data_list <- add_expr( |
| 709 | 43x |
data_list, |
| 710 | 43x |
substitute_names( |
| 711 | 43x |
expr = parentname <- parentname %>% dplyr::mutate( |
| 712 | 43x |
arm_var = droplevels(arm_var) |
| 713 |
), |
|
| 714 | 43x |
names = list( |
| 715 | 43x |
parentname = as.name(parentname), |
| 716 | 43x |
arm_var = as.name(arm_var) |
| 717 |
) |
|
| 718 |
) |
|
| 719 |
) |
|
| 720 |
} else {
|
|
| 721 |
# Keep only levels that exist in `parentname` dataset |
|
| 722 | 14x |
data_list <- add_expr( |
| 723 | 14x |
data_list, |
| 724 | 14x |
substitute_names( |
| 725 | 14x |
expr = parentname <- parentname %>% dplyr::mutate( |
| 726 | 14x |
arm_var = droplevels(arm_var) |
| 727 |
), |
|
| 728 | 14x |
names = list( |
| 729 | 14x |
parentname = as.name(parentname), |
| 730 | 14x |
arm_var = as.name(arm_var) |
| 731 |
) |
|
| 732 |
) |
|
| 733 |
) |
|
| 734 | ||
| 735 | 14x |
data_list <- add_expr( |
| 736 | 14x |
data_list, |
| 737 | 14x |
substitute( |
| 738 | 14x |
expr = arm_levels <- levels(parentname[[arm_var]]), |
| 739 | 14x |
env = list( |
| 740 | 14x |
parentname = as.name(parentname), |
| 741 | 14x |
arm_var = arm_var |
| 742 |
) |
|
| 743 |
) |
|
| 744 |
) |
|
| 745 | ||
| 746 | 14x |
data_list <- add_expr( |
| 747 | 14x |
data_list, |
| 748 | 14x |
substitute_names( |
| 749 | 14x |
expr = dataname <- dataname %>% dplyr::mutate( |
| 750 | 14x |
arm_var = factor(arm_var, levels = arm_levels) |
| 751 |
), |
|
| 752 | 14x |
names = list( |
| 753 | 14x |
dataname = as.name(dataname), |
| 754 | 14x |
arm_var = as.name(arm_var) |
| 755 |
) |
|
| 756 |
) |
|
| 757 |
) |
|
| 758 |
} |
|
| 759 | ||
| 760 | 57x |
bracket_expr(data_list) |
| 761 |
} |
|
| 762 | ||
| 763 |
#' Mapping function for Laboratory Table |
|
| 764 |
#' |
|
| 765 |
#' Map value and level characters to values with with proper html tags, colors and icons. |
|
| 766 |
#' |
|
| 767 |
#' @param x (`character`)\cr vector with elements under the format (`value level`). |
|
| 768 |
#' @param classes (`character`)\cr classes vector. |
|
| 769 |
#' @param colors (`list`)\cr color per class. |
|
| 770 |
#' @param default_color (`character`)\cr default color. |
|
| 771 |
#' @param icons (`list`)\cr certain icons per level. |
|
| 772 |
#' |
|
| 773 |
#' @return a character vector where each element is a formatted HTML tag corresponding to |
|
| 774 |
#' a value in `x`. |
|
| 775 |
#' |
|
| 776 |
#' @examples |
|
| 777 |
#' color_lab_values(c("LOW", "LOW", "HIGH", "NORMAL", "HIGH"))
|
|
| 778 |
#' |
|
| 779 |
#' @export |
|
| 780 |
color_lab_values <- function(x, |
|
| 781 |
classes = c("HIGH", "NORMAL", "LOW"),
|
|
| 782 |
colors = list(HIGH = "red", NORMAL = "grey", LOW = "blue"), |
|
| 783 |
default_color = "black", |
|
| 784 |
icons = list( |
|
| 785 |
HIGH = "glyphicon glyphicon-arrow-up", |
|
| 786 |
LOW = "glyphicon glyphicon-arrow-down" |
|
| 787 |
)) {
|
|
| 788 | 3x |
is_character <- is.character(x) && is.vector(x) |
| 789 | ||
| 790 | 3x |
if ((!is_character) || !any(grepl(sprintf("(?:%s)", paste0(classes, collapse = "|")), x, perl = TRUE))) {
|
| 791 | 2x |
x |
| 792 |
} else {
|
|
| 793 | 1x |
vapply(x, function(val) {
|
| 794 | 5x |
class <- classes[vapply(classes, function(class) {
|
| 795 | 15x |
grepl(sprintf("%s", class), val)
|
| 796 | 5x |
}, logical(1))] |
| 797 | 5x |
if (!is.null(class) & length(class) > 0) {
|
| 798 | 4x |
color <- colors[class] |
| 799 | ! |
if (is.null(color)) color <- default_color |
| 800 | 4x |
icony <- icons[class] |
| 801 | 4x |
value_val <- strsplit(val, " ")[[1]][1] |
| 802 | 4x |
sprintf("<span style='color:%s!important'>%s<i class='%s'></i></span>", color, value_val, icony)
|
| 803 |
} else {
|
|
| 804 | 1x |
val |
| 805 |
} |
|
| 806 | 1x |
}, character(1)) |
| 807 |
} |
|
| 808 |
} |
|
| 809 | ||
| 810 |
#' Clean up categorical variable description |
|
| 811 |
#' |
|
| 812 |
#' Cleaning categorical variable descriptions before presenting. |
|
| 813 |
#' |
|
| 814 |
#' @param x (`character`)\cr vector with categories descriptions. |
|
| 815 |
#' |
|
| 816 |
#' @return a string |
|
| 817 |
#' |
|
| 818 |
#' @examples |
|
| 819 |
#' clean_description("Level A (other text)")
|
|
| 820 |
#' clean_description("A long string that should be shortened")
|
|
| 821 |
#' |
|
| 822 |
#' @export |
|
| 823 |
clean_description <- function(x) {
|
|
| 824 | 2x |
x <- gsub("\\(.*?\\)", "", x)
|
| 825 | 2x |
x <- trimws(x) |
| 826 | 2x |
x <- gsub("[[:space:]]+", " ", x)
|
| 827 | 2x |
x <- ifelse(nchar(x) > 20, |
| 828 | 2x |
yes = paste0(strtrim(x, width = 17), "..."), |
| 829 | 2x |
no = x |
| 830 |
) |
|
| 831 | 2x |
x |
| 832 |
} |
|
| 833 | ||
| 834 |
#' Utility function for extracting `paramcd` for forest plots |
|
| 835 |
#' |
|
| 836 |
#' Utility function for extracting `paramcd` for forest plots |
|
| 837 |
#' |
|
| 838 |
#' @param paramcd [`teal.transform::data_extract_spec()`] |
|
| 839 |
#' variable value designating the studied parameter. |
|
| 840 |
#' |
|
| 841 |
#' @param input shiny app input |
|
| 842 |
#' |
|
| 843 |
#' @param filter_idx filter section index (default 1) |
|
| 844 |
#' @keywords internal |
|
| 845 |
#' |
|
| 846 |
get_g_forest_obj_var_name <- function(paramcd, input, filter_idx = 1) {
|
|
| 847 | 1x |
choices <- paramcd$filter[[filter_idx]]$choices |
| 848 | 1x |
input_obj <- paste0( |
| 849 | 1x |
"paramcd-dataset_", paramcd$dataname, |
| 850 | 1x |
"_singleextract-filter", filter_idx, "-vals" |
| 851 |
) |
|
| 852 | 1x |
current_selected <- input[[input_obj]] |
| 853 | 1x |
obj_var_name <- names(choices)[choices == current_selected] |
| 854 | 1x |
obj_var_name |
| 855 |
} |
|
| 856 | ||
| 857 | ||
| 858 |
#' Extract the associated parameter value for `paramcd` |
|
| 859 |
#' |
|
| 860 |
#' Utility function for extracting the parameter value that is associated |
|
| 861 |
#' with the `paramcd` value label. If there is no parameter value for |
|
| 862 |
#' the `paramcd` label, the `paramcd` value is returned. This is used |
|
| 863 |
#' for generating the title. |
|
| 864 |
#' |
|
| 865 |
#' @param anl Analysis dataset |
|
| 866 |
#' |
|
| 867 |
#' @param paramcd [`teal.transform::data_extract_spec()`] |
|
| 868 |
#' variable value designating the studied parameter. |
|
| 869 |
#' @keywords internal |
|
| 870 |
get_paramcd_label <- function(anl, paramcd) {
|
|
| 871 | ! |
positions <- grep( |
| 872 | ! |
paste(unique(anl[[unlist(paramcd$filter)["vars_selected"]]]), collapse = "|"), |
| 873 | ! |
names(unlist(paramcd$filter)) |
| 874 |
) |
|
| 875 | ! |
label_paramcd <- sapply(positions, function(pos) {
|
| 876 | ! |
if (nchar(sub(".*: ", "", names(unlist(paramcd$filter))[pos])) > 0) {
|
| 877 | ! |
label_paramcd <- sub(".*: ", "", names(unlist(paramcd$filter))[pos])
|
| 878 |
} else {
|
|
| 879 | ! |
label_paramcd <- sub(":.*", "", names(unlist(paramcd$filter))[pos])
|
| 880 | ! |
label_paramcd <- sub(".*\\.", "", label_paramcd)
|
| 881 |
} |
|
| 882 | ! |
label_paramcd |
| 883 |
}) |
|
| 884 |
} |
|
| 885 | ||
| 886 |
as_numeric_from_comma_sep_str <- function(input_string, sep = ",") {
|
|
| 887 | 6x |
if (!is.null(input_string) && trimws(input_string) != "") {
|
| 888 | 4x |
split_string <- unlist(strsplit(trimws(input_string), sep)) |
| 889 | 4x |
split_as_numeric <- suppressWarnings(as.numeric(split_string)) |
| 890 |
} else {
|
|
| 891 | 2x |
split_as_numeric <- NULL |
| 892 |
} |
|
| 893 | 6x |
return(split_as_numeric) |
| 894 |
} |
|
| 895 | ||
| 896 |
#' Default string for total column label |
|
| 897 |
#' |
|
| 898 |
#' @description `r lifecycle::badge("stable")`
|
|
| 899 |
#' |
|
| 900 |
#' The default string used as a label for the "total" column. This value is used as the default |
|
| 901 |
#' value for the `total_label` argument throughout the `teal.modules.clinical` package. If not specified |
|
| 902 |
#' for each module by the user via the `total_label` argument, or in the R environment options via |
|
| 903 |
#' [set_default_total_label()], then `"All Patients"` is used. |
|
| 904 |
#' |
|
| 905 |
#' @param total_label (`string`)\cr Single string value to set in the R environment options as |
|
| 906 |
#' the default label to use for the "total" column. Use `getOption("tmc_default_total_label")` to
|
|
| 907 |
#' check the current value set in the R environment (defaults to `"All Patients"` if not set). |
|
| 908 |
#' |
|
| 909 |
#' @name default_total_label |
|
| 910 |
NULL |
|
| 911 | ||
| 912 |
#' @describeIn default_total_label Getter for default total column label. |
|
| 913 |
#' |
|
| 914 |
#' @return |
|
| 915 |
#' * `default_total_label` returns the current value if an R environment option has been set |
|
| 916 |
#' for `"tmc_default_total_label"`, or `"All Patients"` otherwise. |
|
| 917 |
#' |
|
| 918 |
#' @examples |
|
| 919 |
#' # Default settings |
|
| 920 |
#' default_total_label() |
|
| 921 |
#' getOption("tmc_default_total_label")
|
|
| 922 |
#' |
|
| 923 |
#' # Set custom value |
|
| 924 |
#' set_default_total_label("All Patients")
|
|
| 925 |
#' |
|
| 926 |
#' # Settings after value has been set |
|
| 927 |
#' default_total_label() |
|
| 928 |
#' getOption("tmc_default_total_label")
|
|
| 929 |
#' |
|
| 930 |
#' @export |
|
| 931 |
default_total_label <- function() {
|
|
| 932 | 66x |
getOption("tmc_default_total_label", default = "All Patients")
|
| 933 |
} |
|
| 934 | ||
| 935 |
#' @describeIn default_total_label Setter for default total column label. Sets the |
|
| 936 |
#' option `"tmc_default_total_label"` within the R environment. |
|
| 937 |
#' |
|
| 938 |
#' @return |
|
| 939 |
#' * `set_default_total_label` has no return value. |
|
| 940 |
#' |
|
| 941 |
#' @export |
|
| 942 |
set_default_total_label <- function(total_label) {
|
|
| 943 | 2x |
checkmate::assert_character(total_label, len = 1, null.ok = TRUE) |
| 944 | 2x |
options("tmc_default_total_label" = total_label)
|
| 945 |
} |
|
| 946 | ||
| 947 |
# for mocking in tests |
|
| 948 |
interactive <- NULL |
| 1 |
#' Substitute in Quoted Expressions |
|
| 2 |
#' |
|
| 3 |
#' This version of substitute is needed because [substitute()] does not |
|
| 4 |
#' evaluate it's first argument, and it's often useful to be able to modify |
|
| 5 |
#' a quoted expression. |
|
| 6 |
#' |
|
| 7 |
#' @md |
|
| 8 |
#' @param qexpr (`language`)\cr a quoted expression. |
|
| 9 |
#' @param env (`environment` or `list`)\cr requested variable substitutions. |
|
| 10 |
#' |
|
| 11 |
#' @return The modified expression. |
|
| 12 |
#' @note This is simplified from the package `pryr` to avoid another dependency. |
|
| 13 |
#' @seealso [substitute_names()] |
|
| 14 |
#' |
|
| 15 |
#' @keywords internal |
|
| 16 |
#' |
|
| 17 |
substitute_q <- function(qexpr, env) {
|
|
| 18 | 255x |
stopifnot(is.language(qexpr)) |
| 19 | 254x |
call <- substitute(substitute(qexpr, env), list(qexpr = qexpr)) |
| 20 | 254x |
eval(call) |
| 21 |
} |
|
| 22 | ||
| 23 |
#' Substitute Names in a Quoted Expression |
|
| 24 |
#' |
|
| 25 |
#' This function substitutes the names on both left- and right-hand sides in a quoted expression. |
|
| 26 |
#' In addition it can also do other standard substitutions on the right-hand side. |
|
| 27 |
#' |
|
| 28 |
#' @md |
|
| 29 |
#' @param expr (`language`)\cr an expression. |
|
| 30 |
#' @param names (named `list` of `name`)\cr requested name substitutions. |
|
| 31 |
#' @param others (named `list`)\cr requested other substitutions which will only happen on the |
|
| 32 |
#' right-hand side. |
|
| 33 |
#' |
|
| 34 |
#' @name substitute_names |
|
| 35 |
#' @return The modified expression. |
|
| 36 |
#' @seealso [substitute_q()] |
|
| 37 |
#' |
|
| 38 |
#' @keywords internal |
|
| 39 |
#' |
|
| 40 |
substitute_names <- function(expr, names, others = list()) {
|
|
| 41 | 252x |
checkmate::assert_list(names, min.len = 1, names = "unique", types = "name") |
| 42 | 252x |
checkmate::assert_list(others, min.len = 0, names = "unique") |
| 43 | 252x |
checkmate::assert_names(names(names), disjunct.from = names(others)) |
| 44 | ||
| 45 | 252x |
expr <- substitute(expr) |
| 46 | 252x |
expr <- substitute_rhs(expr, c(names, others)) |
| 47 | 252x |
substitute_lhs_names(expr, names) |
| 48 |
} |
|
| 49 | ||
| 50 |
#' @md |
|
| 51 |
#' @describeIn substitute_names Helper function to just substitute the top-level names on the left-hand side in a |
|
| 52 |
#' quoted expression. |
|
| 53 |
#' @inheritParams substitute_q |
|
| 54 |
#' @keywords internal |
|
| 55 |
h_subst_lhs_names <- function(qexpr, names) {
|
|
| 56 | 1137x |
will_replace <- names(names) |
| 57 | 1137x |
to_replace <- names(qexpr) |
| 58 | 1137x |
matches <- match(x = to_replace, table = will_replace) |
| 59 | 1137x |
which_found <- which(!is.na(matches)) |
| 60 | 1137x |
names_as_strings <- sapply(names, as.character) |
| 61 | 1137x |
names(qexpr)[which_found] <- names_as_strings[matches[which_found]] |
| 62 | 1137x |
qexpr |
| 63 |
} |
|
| 64 | ||
| 65 |
#' @md |
|
| 66 |
#' @describeIn substitute_names recursively substitutes all names on the left-hand sides in a quoted expression. |
|
| 67 |
#' @inheritParams substitute_q |
|
| 68 |
#' @keywords internal |
|
| 69 |
substitute_lhs_names <- function(qexpr, names) {
|
|
| 70 | 3217x |
if (length(qexpr) == 1L) {
|
| 71 | 2081x |
return(qexpr) |
| 72 |
} |
|
| 73 | 1136x |
qexpr <- h_subst_lhs_names(qexpr, names) |
| 74 | 1136x |
for (i in seq_along(qexpr)) {
|
| 75 | 2963x |
qexpr[[i]] <- substitute_lhs_names(qexpr[[i]], names) |
| 76 |
} |
|
| 77 | 1136x |
qexpr |
| 78 |
} |
|
| 79 | ||
| 80 |
#' @md |
|
| 81 |
#' @describeIn substitute_names substitutes on the right-hand side in a quoted expression. |
|
| 82 |
#' Note that this is just a synonym for [substitute_q()]. |
|
| 83 |
#' @inheritParams substitute_q |
|
| 84 |
#' @keywords internal |
|
| 85 |
substitute_rhs <- function(qexpr, env) {
|
|
| 86 | 253x |
substitute_q(qexpr, env) |
| 87 |
} |
| 1 |
#' Template: Logistic Regression |
|
| 2 |
#' |
|
| 3 |
#' Creates a valid expression to generate a logistic regression table. |
|
| 4 |
#' |
|
| 5 |
#' @inheritParams template_arguments |
|
| 6 |
#' @inheritParams tern::tidy.glm |
|
| 7 |
#' @param arm_var (`character`)\cr variable names that can be used as `arm_var`. To fit a logistic model with no |
|
| 8 |
#' arm/treatment variable, set to `NULL`. |
|
| 9 |
#' @param topleft (`character`)\cr text to use as top-left annotation in the table. |
|
| 10 |
#' @param interaction_var (`character`)\cr names of the variables that can be used for interaction variable selection. |
|
| 11 |
#' @param responder_val (`character`)\cr values of the responder variable corresponding with a successful response. |
|
| 12 |
#' @param paramcd `r lifecycle::badge("deprecated")` The `paramcd` argument is not used in this function.
|
|
| 13 |
#' @param label_paramcd (`character`)\cr label of response parameter value to print in the table title. |
|
| 14 |
#' |
|
| 15 |
#' @inherit template_arguments return |
|
| 16 |
#' |
|
| 17 |
#' @seealso [tm_t_logistic()] |
|
| 18 |
#' |
|
| 19 |
#' @keywords internal |
|
| 20 |
template_logistic <- function(dataname, |
|
| 21 |
arm_var, |
|
| 22 |
aval_var, |
|
| 23 |
paramcd = lifecycle::deprecated(), |
|
| 24 |
label_paramcd, |
|
| 25 |
cov_var, |
|
| 26 |
interaction_var, |
|
| 27 |
ref_arm, |
|
| 28 |
comp_arm, |
|
| 29 |
topleft = "Logistic Regression", |
|
| 30 |
conf_level = 0.95, |
|
| 31 |
combine_comp_arms = FALSE, |
|
| 32 |
responder_val = c("CR", "PR"),
|
|
| 33 |
at = NULL, |
|
| 34 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 35 | 3x |
if (lifecycle::is_present(paramcd)) {
|
| 36 | ! |
lifecycle::deprecate_warn("0.8.16", "template_logistic(paramcd)")
|
| 37 |
} |
|
| 38 | ||
| 39 |
# Common assertion no matter if arm_var is NULL or not. |
|
| 40 | 3x |
checkmate::assert_string(dataname) |
| 41 | 3x |
checkmate::assert_string(aval_var) |
| 42 | 3x |
checkmate::assert_string(label_paramcd, null.ok = TRUE) |
| 43 | 3x |
checkmate::assert_string(topleft, null.ok = TRUE) |
| 44 | 3x |
checkmate::assert_character(cov_var, null.ok = TRUE) |
| 45 | 3x |
checkmate::assert_string(interaction_var, null.ok = TRUE) |
| 46 | ||
| 47 | 3x |
y <- list() |
| 48 | ||
| 49 | 3x |
data_pipe <- list() |
| 50 | 3x |
data_list <- list() |
| 51 | ||
| 52 |
# Conditional assertion depends on if arm_var isn't NULL. |
|
| 53 | 3x |
if (!is.null(arm_var)) {
|
| 54 | 2x |
checkmate::assert_string(arm_var) |
| 55 | 2x |
checkmate::assert_flag(combine_comp_arms) |
| 56 | ||
| 57 | 2x |
ref_arm_val <- paste(ref_arm, collapse = "/") |
| 58 | ||
| 59 | 2x |
y$arm_lab <- substitute( |
| 60 | 2x |
expr = arm_var_lab <- teal.data::col_labels(anl[arm_var], fill = FALSE), |
| 61 | 2x |
env = list(anl = as.name(dataname), arm_var = arm_var) |
| 62 |
) |
|
| 63 | ||
| 64 |
# Start to build data when arm_var is not NULL. |
|
| 65 | 2x |
data_pipe <- add_expr( |
| 66 | 2x |
data_pipe, |
| 67 | 2x |
prepare_arm( |
| 68 | 2x |
dataname = dataname, |
| 69 | 2x |
arm_var = arm_var, |
| 70 | 2x |
ref_arm = ref_arm, |
| 71 | 2x |
comp_arm = comp_arm, |
| 72 | 2x |
ref_arm_val = ref_arm_val |
| 73 |
) |
|
| 74 |
) |
|
| 75 | ||
| 76 | 2x |
if (combine_comp_arms) {
|
| 77 | ! |
data_pipe <- add_expr( |
| 78 | ! |
data_pipe, |
| 79 | ! |
substitute_names( |
| 80 | ! |
expr = dplyr::mutate(arm_var = combine_levels(x = arm_var, levels = comp_arm)), |
| 81 | ! |
names = list(arm_var = as.name(arm_var)), |
| 82 | ! |
others = list(comp_arm = comp_arm) |
| 83 |
) |
|
| 84 |
) |
|
| 85 |
} |
|
| 86 | ||
| 87 | 2x |
data_list <- add_expr( |
| 88 | 2x |
data_list, |
| 89 | 2x |
substitute( |
| 90 | 2x |
expr = ANL <- data_pipe, |
| 91 | 2x |
env = list(data_pipe = pipe_expr(data_pipe)) |
| 92 |
) |
|
| 93 |
) |
|
| 94 |
} |
|
| 95 | ||
| 96 | 3x |
data_list <- add_expr( |
| 97 | 3x |
data_list, |
| 98 | 3x |
substitute( |
| 99 | 3x |
expr = ANL <- df %>% |
| 100 | 3x |
dplyr::mutate(Response = aval_var %in% responder_val) %>% |
| 101 | 3x |
df_explicit_na(na_level = "_NA_"), |
| 102 | 3x |
env = list(df = as.name("ANL"), aval_var = as.name(aval_var), responder_val = responder_val)
|
| 103 |
) |
|
| 104 |
) |
|
| 105 | ||
| 106 | 3x |
y$data <- bracket_expr(data_list) |
| 107 | ||
| 108 | 3x |
if (!is.null(arm_var)) {
|
| 109 | 2x |
y$relabel <- substitute( |
| 110 | 2x |
expr = teal.data::col_labels(ANL[arm_var]) <- arm_var_lab, |
| 111 | 2x |
env = list(arm_var = arm_var) |
| 112 |
) |
|
| 113 |
} |
|
| 114 | ||
| 115 | 3x |
model_list <- list() |
| 116 | 3x |
model_list <- if (is.null(interaction_var)) {
|
| 117 | ! |
add_expr( |
| 118 | ! |
model_list, |
| 119 | ! |
substitute( |
| 120 | ! |
expr = fit_logistic( |
| 121 | ! |
ANL, |
| 122 | ! |
variables = list(response = "Response", arm = arm_var, covariates = cov_var) |
| 123 |
), |
|
| 124 | ! |
env = list(arm_var = arm_var, cov_var = cov_var) |
| 125 |
) |
|
| 126 |
) |
|
| 127 |
} else {
|
|
| 128 | 3x |
add_expr( |
| 129 | 3x |
model_list, |
| 130 | 3x |
substitute( |
| 131 | 3x |
expr = fit_logistic( |
| 132 | 3x |
ANL, |
| 133 | 3x |
variables = list( |
| 134 | 3x |
response = "Response", arm = arm_var, covariates = cov_var, |
| 135 | 3x |
interaction = interaction_var |
| 136 |
) |
|
| 137 |
), |
|
| 138 | 3x |
env = list(arm_var = arm_var, cov_var = cov_var, interaction_var = interaction_var) |
| 139 |
) |
|
| 140 |
) |
|
| 141 |
} |
|
| 142 | ||
| 143 | 3x |
model_list <- if (is.null(interaction_var)) {
|
| 144 | ! |
add_expr( |
| 145 | ! |
model_list, |
| 146 | ! |
substitute( |
| 147 | ! |
expr = broom::tidy(conf_level = conf_level), |
| 148 | ! |
env = list(conf_level = conf_level) |
| 149 |
) |
|
| 150 |
) |
|
| 151 |
} else {
|
|
| 152 | 3x |
add_expr( |
| 153 | 3x |
model_list, |
| 154 | 3x |
substitute( |
| 155 | 3x |
expr = broom::tidy(conf_level = conf_level, at = at), |
| 156 | 3x |
env = list(conf_level = conf_level, at = at) |
| 157 |
) |
|
| 158 |
) |
|
| 159 |
} |
|
| 160 | ||
| 161 | 3x |
model_list <- add_expr(model_list, quote(df_explicit_na(na_level = "_NA_"))) |
| 162 | ||
| 163 | 3x |
y$model <- substitute( |
| 164 | 3x |
expr = mod <- model_pipe, |
| 165 | 3x |
env = list(model_pipe = pipe_expr(model_list)) |
| 166 |
) |
|
| 167 | ||
| 168 | 3x |
layout_list <- list() |
| 169 | ||
| 170 | 3x |
basic_title <- if (length(responder_val) > 1) {
|
| 171 | ! |
paste( |
| 172 | ! |
"Summary of Logistic Regression Analysis for", label_paramcd, "for", |
| 173 | ! |
paste(utils::head(responder_val, -1), collapse = ", "), |
| 174 | ! |
"and", utils::tail(responder_val, 1), "Responders" |
| 175 |
) |
|
| 176 |
} else {
|
|
| 177 | 3x |
paste("Summary of Logistic Regression Analysis for", label_paramcd, "for", responder_val, "Responders")
|
| 178 |
} |
|
| 179 | ||
| 180 | 3x |
parsed_basic_table_args <- teal.widgets::parse_basic_table_args( |
| 181 | 3x |
teal.widgets::resolve_basic_table_args( |
| 182 | 3x |
user_table = basic_table_args, |
| 183 | 3x |
module_table = teal.widgets::basic_table_args(title = basic_title) |
| 184 |
) |
|
| 185 |
) |
|
| 186 | ||
| 187 | 3x |
y$table <- substitute( |
| 188 | 3x |
expr = {
|
| 189 | ! |
result <- expr_basic_table_args %>% |
| 190 | ! |
summarize_logistic( |
| 191 | ! |
conf_level = conf_level, |
| 192 | ! |
drop_and_remove_str = "_NA_" |
| 193 |
) %>% |
|
| 194 | ! |
rtables::append_topleft(topleft) %>% |
| 195 | ! |
rtables::build_table(df = mod) |
| 196 | ! |
result |
| 197 |
}, |
|
| 198 | 3x |
env = list( |
| 199 | 3x |
expr_basic_table_args = parsed_basic_table_args, |
| 200 | 3x |
conf_level = conf_level, |
| 201 | 3x |
topleft = topleft |
| 202 |
) |
|
| 203 |
) |
|
| 204 | ||
| 205 | 3x |
y |
| 206 |
} |
|
| 207 | ||
| 208 |
#' teal Module: Logistic Regression |
|
| 209 |
#' |
|
| 210 |
#' This module produces a multi-variable logistic regression table consistent with the TLG Catalog template |
|
| 211 |
#' `LGRT02` available [here](https://insightsengineering.github.io/tlg-catalog/stable/tables/efficacy/lgrt02.html). |
|
| 212 |
#' |
|
| 213 |
#' @inheritParams module_arguments |
|
| 214 |
#' @inheritParams template_logistic |
|
| 215 |
#' @param arm_var ([teal.transform::choices_selected()] or `NULL`)\cr object |
|
| 216 |
#' with all available choices and preselected option for variable names that can be used as `arm_var`. This defines |
|
| 217 |
#' the grouping variable(s) in the results table. If there are two elements selected for `arm_var`, the second |
|
| 218 |
#' variable will be nested under the first variable. If `NULL`, no arm/treatment variable is included in the |
|
| 219 |
#' logistic model. |
|
| 220 |
#' @param avalc_var ([teal.transform::choices_selected()])\cr object with all |
|
| 221 |
#' available choices and preselected option for the analysis variable (categorical). |
|
| 222 |
#' |
|
| 223 |
#' @inherit module_arguments return seealso |
|
| 224 |
#' |
|
| 225 |
#' @examples |
|
| 226 |
#' library(dplyr) |
|
| 227 |
#' |
|
| 228 |
#' ADSL <- tmc_ex_adsl |
|
| 229 |
#' ADRS <- tmc_ex_adrs %>% |
|
| 230 |
#' filter(PARAMCD %in% c("BESRSPI", "INVET"))
|
|
| 231 |
#' |
|
| 232 |
#' arm_ref_comp <- list( |
|
| 233 |
#' ACTARMCD = list( |
|
| 234 |
#' ref = "ARM B", |
|
| 235 |
#' comp = c("ARM A", "ARM C")
|
|
| 236 |
#' ), |
|
| 237 |
#' ARM = list( |
|
| 238 |
#' ref = "B: Placebo", |
|
| 239 |
#' comp = c("A: Drug X", "C: Combination")
|
|
| 240 |
#' ) |
|
| 241 |
#' ) |
|
| 242 |
#' |
|
| 243 |
#' app <- init( |
|
| 244 |
#' data = cdisc_data( |
|
| 245 |
#' ADSL = ADSL, |
|
| 246 |
#' ADRS = ADRS, |
|
| 247 |
#' code = " |
|
| 248 |
#' ADSL <- tmc_ex_adsl |
|
| 249 |
#' ADRS <- tmc_ex_adrs %>% |
|
| 250 |
#' filter(PARAMCD %in% c(\"BESRSPI\", \"INVET\")) |
|
| 251 |
#' " |
|
| 252 |
#' ), |
|
| 253 |
#' modules = modules( |
|
| 254 |
#' tm_t_logistic( |
|
| 255 |
#' label = "Logistic Regression", |
|
| 256 |
#' dataname = "ADRS", |
|
| 257 |
#' arm_var = choices_selected( |
|
| 258 |
#' choices = variable_choices(ADRS, c("ARM", "ARMCD")),
|
|
| 259 |
#' selected = "ARM" |
|
| 260 |
#' ), |
|
| 261 |
#' arm_ref_comp = arm_ref_comp, |
|
| 262 |
#' paramcd = choices_selected( |
|
| 263 |
#' choices = value_choices(ADRS, "PARAMCD", "PARAM"), |
|
| 264 |
#' selected = "BESRSPI" |
|
| 265 |
#' ), |
|
| 266 |
#' cov_var = choices_selected( |
|
| 267 |
#' choices = c("SEX", "AGE", "BMRKR1", "BMRKR2"),
|
|
| 268 |
#' selected = "SEX" |
|
| 269 |
#' ) |
|
| 270 |
#' ) |
|
| 271 |
#' ) |
|
| 272 |
#' ) |
|
| 273 |
#' if (interactive()) {
|
|
| 274 |
#' shinyApp(app$ui, app$server) |
|
| 275 |
#' } |
|
| 276 |
#' |
|
| 277 |
#' @export |
|
| 278 |
tm_t_logistic <- function(label, |
|
| 279 |
dataname, |
|
| 280 |
parentname = ifelse( |
|
| 281 |
inherits(arm_var, "data_extract_spec"), |
|
| 282 |
teal.transform::datanames_input(arm_var), |
|
| 283 |
"ADSL" |
|
| 284 |
), |
|
| 285 |
arm_var = NULL, |
|
| 286 |
arm_ref_comp = NULL, |
|
| 287 |
paramcd, |
|
| 288 |
cov_var = NULL, |
|
| 289 |
avalc_var = teal.transform::choices_selected( |
|
| 290 |
teal.transform::variable_choices(dataname, "AVALC"), "AVALC", |
|
| 291 |
fixed = TRUE |
|
| 292 |
), |
|
| 293 |
conf_level = teal.transform::choices_selected(c(0.95, 0.9, 0.8), 0.95, keep_order = TRUE), |
|
| 294 |
pre_output = NULL, |
|
| 295 |
post_output = NULL, |
|
| 296 |
basic_table_args = teal.widgets::basic_table_args()) {
|
|
| 297 | ! |
message("Initializing tm_t_logistic")
|
| 298 | ! |
checkmate::assert_string(label) |
| 299 | ! |
checkmate::assert_string(dataname) |
| 300 | ! |
checkmate::assert_string(parentname) |
| 301 | ! |
checkmate::assert_class(arm_var, "choices_selected", null.ok = TRUE) |
| 302 | ! |
checkmate::assert_class(paramcd, "choices_selected") |
| 303 | ! |
checkmate::assert_class(cov_var, "choices_selected", null.ok = TRUE) |
| 304 | ! |
checkmate::assert_class(avalc_var, "choices_selected") |
| 305 | ! |
checkmate::assert_class(conf_level, "choices_selected") |
| 306 | ! |
checkmate::assert_list(arm_ref_comp, names = "named", null.ok = TRUE) |
| 307 | ! |
checkmate::assert_class(pre_output, classes = "shiny.tag", null.ok = TRUE) |
| 308 | ! |
checkmate::assert_class(post_output, classes = "shiny.tag", null.ok = TRUE) |
| 309 | ! |
checkmate::assert_class(basic_table_args, "basic_table_args") |
| 310 | ||
| 311 | ! |
args <- as.list(environment()) |
| 312 | ||
| 313 | ! |
data_extract_list <- list( |
| 314 | ! |
arm_var = `if`(is.null(arm_var), NULL, cs_to_des_select(arm_var, dataname = parentname)), |
| 315 | ! |
paramcd = cs_to_des_filter(paramcd, dataname = dataname), |
| 316 | ! |
cov_var = cs_to_des_select(cov_var, dataname = dataname, multiple = TRUE), |
| 317 | ! |
avalc_var = cs_to_des_select(avalc_var, dataname = dataname) |
| 318 |
) |
|
| 319 | ||
| 320 | ! |
module( |
| 321 | ! |
label = label, |
| 322 | ! |
server = srv_t_logistic, |
| 323 | ! |
ui = ui_t_logistic, |
| 324 | ! |
ui_args = c(data_extract_list, args), |
| 325 | ! |
server_args = c( |
| 326 | ! |
data_extract_list, |
| 327 | ! |
list( |
| 328 | ! |
arm_ref_comp = arm_ref_comp, |
| 329 | ! |
label = label, |
| 330 | ! |
dataname = dataname, |
| 331 | ! |
parentname = parentname, |
| 332 | ! |
basic_table_args = basic_table_args |
| 333 |
) |
|
| 334 |
), |
|
| 335 | ! |
datanames = teal.transform::get_extract_datanames(data_extract_list) |
| 336 |
) |
|
| 337 |
} |
|
| 338 | ||
| 339 |
#' @keywords internal |
|
| 340 |
ui_t_logistic <- function(id, ...) {
|
|
| 341 | ! |
a <- list(...) |
| 342 | ! |
if (!is.null(a$arm_var)) {
|
| 343 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 344 | ! |
a$arm_var, |
| 345 | ! |
a$paramcd, |
| 346 | ! |
a$avalc_var, |
| 347 | ! |
a$cov_var |
| 348 |
) |
|
| 349 |
} else {
|
|
| 350 | ! |
is_single_dataset_value <- teal.transform::is_single_dataset( |
| 351 | ! |
a$paramcd, |
| 352 | ! |
a$avalc_var, |
| 353 | ! |
a$cov_var |
| 354 |
) |
|
| 355 |
} |
|
| 356 | ||
| 357 | ! |
ns <- NS(id) |
| 358 | ! |
teal.widgets::standard_layout( |
| 359 | ! |
output = teal.widgets::white_small_well( |
| 360 | ! |
teal.widgets::table_with_settings_ui(ns("table"))
|
| 361 |
), |
|
| 362 | ! |
encoding = tags$div( |
| 363 |
### Reporter |
|
| 364 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 365 |
### |
|
| 366 | ! |
tags$label("Encodings", class = "text-primary"),
|
| 367 | ! |
teal.transform::datanames_input(a[c("arm_var", "paramcd", "avalc_var", "cov_var")]),
|
| 368 | ! |
teal.transform::data_extract_ui( |
| 369 | ! |
id = ns("paramcd"),
|
| 370 | ! |
label = "Select Endpoint", |
| 371 | ! |
data_extract_spec = a$paramcd, |
| 372 | ! |
is_single_dataset = is_single_dataset_value |
| 373 |
), |
|
| 374 | ! |
teal.transform::data_extract_ui( |
| 375 | ! |
id = ns("avalc_var"),
|
| 376 | ! |
label = "Analysis Variable", |
| 377 | ! |
data_extract_spec = a$avalc_var, |
| 378 | ! |
is_single_dataset = is_single_dataset_value |
| 379 |
), |
|
| 380 | ! |
selectInput( |
| 381 | ! |
ns("responders"),
|
| 382 | ! |
"Responders", |
| 383 | ! |
choices = c("CR", "PR"),
|
| 384 | ! |
selected = c("CR", "PR"),
|
| 385 | ! |
multiple = TRUE |
| 386 |
), |
|
| 387 | ! |
if (!is.null(a$arm_var)) {
|
| 388 | ! |
tags$div( |
| 389 | ! |
teal.transform::data_extract_ui( |
| 390 | ! |
id = ns("arm_var"),
|
| 391 | ! |
label = "Select Treatment Variable", |
| 392 | ! |
data_extract_spec = a$arm_var, |
| 393 | ! |
is_single_dataset = is_single_dataset_value |
| 394 |
), |
|
| 395 | ! |
uiOutput(ns("arms_buckets")),
|
| 396 | ! |
checkboxInput( |
| 397 | ! |
ns("combine_comp_arms"),
|
| 398 | ! |
"Combine all comparison groups?", |
| 399 | ! |
value = FALSE |
| 400 |
) |
|
| 401 |
) |
|
| 402 |
}, |
|
| 403 | ! |
teal.transform::data_extract_ui( |
| 404 | ! |
id = ns("cov_var"),
|
| 405 | ! |
label = "Covariates", |
| 406 | ! |
data_extract_spec = a$cov_var, |
| 407 | ! |
is_single_dataset = is_single_dataset_value |
| 408 |
), |
|
| 409 | ! |
uiOutput(ns("interaction_variable")),
|
| 410 | ! |
uiOutput(ns("interaction_input")),
|
| 411 | ! |
teal.widgets::optionalSelectInput( |
| 412 | ! |
inputId = ns("conf_level"),
|
| 413 | ! |
label = tags$p( |
| 414 | ! |
"Confidence level for ", |
| 415 | ! |
tags$span(class = "text-primary", "Coxph"), |
| 416 | ! |
" (Hazard Ratio)", |
| 417 | ! |
sep = "" |
| 418 |
), |
|
| 419 | ! |
a$conf_level$choices, |
| 420 | ! |
a$conf_level$selected, |
| 421 | ! |
multiple = FALSE, |
| 422 | ! |
fixed = a$conf_level$fixed |
| 423 |
) |
|
| 424 |
), |
|
| 425 | ! |
forms = tagList( |
| 426 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), button_label = "Show R code")
|
| 427 |
), |
|
| 428 | ! |
pre_output = a$pre_output, |
| 429 | ! |
post_output = a$post_output |
| 430 |
) |
|
| 431 |
} |
|
| 432 | ||
| 433 |
#' @keywords internal |
|
| 434 |
srv_t_logistic <- function(id, |
|
| 435 |
data, |
|
| 436 |
reporter, |
|
| 437 |
filter_panel_api, |
|
| 438 |
dataname, |
|
| 439 |
parentname, |
|
| 440 |
arm_var, |
|
| 441 |
arm_ref_comp, |
|
| 442 |
paramcd, |
|
| 443 |
avalc_var, |
|
| 444 |
cov_var, |
|
| 445 |
label, |
|
| 446 |
basic_table_args) {
|
|
| 447 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 448 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
| 449 | ! |
checkmate::assert_class(data, "reactive") |
| 450 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 451 | ||
| 452 | ! |
moduleServer(id, function(input, output, session) {
|
| 453 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.clinical") |
| 454 |
# Observer to update reference and comparison arm input options. |
|
| 455 | ! |
iv_arco <- arm_ref_comp_observer( |
| 456 | ! |
session, |
| 457 | ! |
input, |
| 458 | ! |
output, |
| 459 | ! |
id_arm_var = extract_input("arm_var", parentname),
|
| 460 | ! |
data = reactive(data()[[parentname]]), |
| 461 | ! |
arm_ref_comp = arm_ref_comp, |
| 462 | ! |
module = "tm_t_logistic" |
| 463 |
) |
|
| 464 | ||
| 465 | ! |
selector_list <- teal.transform::data_extract_multiple_srv( |
| 466 | ! |
data_extract = list( |
| 467 | ! |
arm_var = arm_var, |
| 468 | ! |
paramcd = paramcd, |
| 469 | ! |
avalc_var = avalc_var, |
| 470 | ! |
cov_var = cov_var |
| 471 |
), |
|
| 472 | ! |
datasets = data, |
| 473 | ! |
select_validation_rule = list( |
| 474 | ! |
arm_var = shinyvalidate::sv_required("Treatment Variable is empty"),
|
| 475 | ! |
avalc_var = shinyvalidate::sv_required("Analysis variable is empty"),
|
| 476 | ! |
cov_var = shinyvalidate::sv_required("`Covariates` field is empty")
|
| 477 |
), |
|
| 478 | ! |
filter_validation_rule = list( |
| 479 | ! |
paramcd = shinyvalidate::sv_required("`Select Endpoint` field is empty")
|
| 480 |
) |
|
| 481 |
) |
|
| 482 | ||
| 483 | ! |
iv_r <- reactive({
|
| 484 | ! |
iv <- shinyvalidate::InputValidator$new() |
| 485 | ! |
iv$add_rule("responders", shinyvalidate::sv_required("`Responders` field is empty"))
|
| 486 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_required("Please choose a confidence level."))
|
| 487 | ! |
iv$add_rule("conf_level", shinyvalidate::sv_between(
|
| 488 | ! |
0, 1, |
| 489 | ! |
message_fmt = "Confdence level must be between {left} and {right}."
|
| 490 |
)) |
|
| 491 | ! |
iv$add_validator(iv_arco) |
| 492 |
# Conditional validator for interaction values. |
|
| 493 | ! |
iv_int <- shinyvalidate::InputValidator$new() |
| 494 | ! |
iv_int$condition( |
| 495 | ! |
~ length(input$interaction_var) > 0L && |
| 496 | ! |
is.numeric(merged$anl_q()[["ANL"]][[input$interaction_var]]) |
| 497 |
) |
|
| 498 | ! |
iv_int$add_rule("interaction_values", shinyvalidate::sv_required(
|
| 499 | ! |
"If interaction is specified the level should be entered." |
| 500 |
)) |
|
| 501 | ! |
iv_int$add_rule( |
| 502 | ! |
"interaction_values", |
| 503 | ! |
~ if (anyNA(as_numeric_from_comma_sep_str(.))) {
|
| 504 | ! |
"Interaction levels are invalid." |
| 505 |
} |
|
| 506 |
) |
|
| 507 | ! |
iv_int$add_rule( |
| 508 | ! |
"interaction_values", |
| 509 | ! |
~ if (any(duplicated(as_numeric_from_comma_sep_str(.)))) {
|
| 510 | ! |
"Interaction levels must be unique." |
| 511 |
} |
|
| 512 |
) |
|
| 513 | ! |
iv$add_validator(iv_int) |
| 514 | ! |
teal.transform::compose_and_enable_validators(iv, selector_list) |
| 515 |
}) |
|
| 516 | ||
| 517 | ! |
anl_inputs <- teal.transform::merge_expression_srv( |
| 518 | ! |
selector_list = selector_list, |
| 519 | ! |
datasets = data, |
| 520 | ! |
merge_function = "dplyr::inner_join" |
| 521 |
) |
|
| 522 | ||
| 523 | ! |
adsl_inputs <- teal.transform::merge_expression_module( |
| 524 | ! |
datasets = data, |
| 525 | ! |
data_extract = list(arm_var = arm_var), |
| 526 | ! |
anl_name = "ANL_ADSL" |
| 527 |
) |
|
| 528 | ||
| 529 | ! |
anl_q <- reactive({
|
| 530 | ! |
data() %>% |
| 531 | ! |
teal.code::eval_code(as.expression(anl_inputs()$expr)) %>% |
| 532 | ! |
teal.code::eval_code(as.expression(adsl_inputs()$expr)) |
| 533 |
}) |
|
| 534 | ||
| 535 | ! |
merged <- list( |
| 536 | ! |
anl_input_r = anl_inputs, |
| 537 | ! |
adsl_input_r = adsl_inputs, |
| 538 | ! |
anl_q = anl_q |
| 539 |
) |
|
| 540 | ||
| 541 |
# Because the AVALC values depends on the selected PARAMCD. |
|
| 542 | ! |
observeEvent(merged$anl_input_r(), {
|
| 543 | ! |
avalc_var <- merged$anl_input_r()$columns_source$avalc_var |
| 544 | ! |
if (nrow(merged$anl_q()[["ANL"]]) == 0) {
|
| 545 | ! |
responder_choices <- c("CR", "PR")
|
| 546 | ! |
responder_sel <- c("CR", "PR")
|
| 547 |
} else {
|
|
| 548 | ! |
if (length(avalc_var) == 0) {
|
| 549 | ! |
return(NULL) |
| 550 |
} |
|
| 551 | ! |
responder_choices <- unique(merged$anl_q()[["ANL"]][[avalc_var]]) |
| 552 | ! |
responder_sel <- intersect(responder_choices, isolate(input$responders)) |
| 553 |
} |
|
| 554 | ! |
updateSelectInput( |
| 555 | ! |
session, "responders", |
| 556 | ! |
choices = responder_choices, |
| 557 | ! |
selected = responder_sel |
| 558 |
) |
|
| 559 |
}) |
|
| 560 | ||
| 561 | ! |
output$interaction_variable <- renderUI({
|
| 562 | ! |
cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) |
| 563 | ! |
if (length(cov_var) > 0) {
|
| 564 | ! |
teal.widgets::optionalSelectInput( |
| 565 | ! |
session$ns("interaction_var"),
|
| 566 | ! |
label = "Interaction", |
| 567 | ! |
choices = cov_var, |
| 568 | ! |
selected = NULL, |
| 569 | ! |
multiple = FALSE |
| 570 |
) |
|
| 571 |
} else {
|
|
| 572 | ! |
NULL |
| 573 |
} |
|
| 574 |
}) |
|
| 575 | ||
| 576 | ! |
output$interaction_input <- renderUI({
|
| 577 | ! |
interaction_var <- input$interaction_var |
| 578 | ! |
if (length(interaction_var) > 0) {
|
| 579 | ! |
if (is.numeric(merged$anl_q()[["ANL"]][[interaction_var]])) {
|
| 580 | ! |
tagList( |
| 581 | ! |
textInput( |
| 582 | ! |
session$ns("interaction_values"),
|
| 583 | ! |
label = sprintf("Specify %s values (comma delimited) for treatment ORs calculation:", interaction_var),
|
| 584 | ! |
value = as.character(stats::median(merged$anl_q()[["ANL"]][[interaction_var]])) |
| 585 |
) |
|
| 586 |
) |
|
| 587 |
} |
|
| 588 |
} else {
|
|
| 589 | ! |
NULL |
| 590 |
} |
|
| 591 |
}) |
|
| 592 | ||
| 593 | ! |
validate_checks <- reactive({
|
| 594 | ! |
adsl_filtered <- anl_q()[[parentname]] |
| 595 | ! |
anl_filtered <- anl_q()[[dataname]] |
| 596 | ||
| 597 | ! |
validate_inputs(iv_r()) |
| 598 | ||
| 599 | ! |
input_arm_var <- as.vector(merged$anl_input_r()$columns_source$arm_var) |
| 600 | ! |
input_avalc_var <- as.vector(merged$anl_input_r()$columns_source$avalc_var) |
| 601 | ! |
input_cov_var <- as.vector(merged$anl_input_r()$columns_source$cov_var) |
| 602 | ! |
input_paramcd <- unlist(paramcd$filter)["vars_selected"] |
| 603 | ! |
input_interaction_var <- input$interaction_var |
| 604 | ||
| 605 | ! |
input_interaction_at <- input_interaction_var[input_interaction_var %in% input_cov_var] |
| 606 | ||
| 607 | ! |
at_values <- as_numeric_from_comma_sep_str(input$interaction_values) |
| 608 | ||
| 609 |
# validate inputs |
|
| 610 | ! |
validate_args <- list( |
| 611 | ! |
adsl = adsl_filtered, |
| 612 | ! |
adslvars = c("USUBJID", "STUDYID", input_arm_var),
|
| 613 | ! |
anl = anl_filtered, |
| 614 | ! |
anlvars = c("USUBJID", "STUDYID", input_paramcd, input_avalc_var, input_cov_var),
|
| 615 | ! |
arm_var = input_arm_var, |
| 616 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 617 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 618 | ! |
min_nrow = 4 |
| 619 |
) |
|
| 620 | ||
| 621 |
# validate arm levels |
|
| 622 | ! |
if (!is.null(arm_var)) {
|
| 623 | ! |
if (length(input_arm_var) > 0 && length(unique(adsl_filtered[[input_arm_var]])) == 1) {
|
| 624 | ! |
validate_args <- append(validate_args, list(min_n_levels_armvar = NULL)) |
| 625 |
} |
|
| 626 | ||
| 627 | ! |
do.call(what = "validate_standard_inputs", validate_args) |
| 628 | ||
| 629 | ! |
arm_n <- base::table(merged$anl_q()[["ANL"]][[input_arm_var]]) |
| 630 | ! |
anl_arm_n <- if (input$combine_comp_arms) {
|
| 631 | ! |
c(sum(arm_n[unlist(input$buckets$Ref)]), sum(arm_n[unlist(input$buckets$Comp)])) |
| 632 |
} else {
|
|
| 633 | ! |
c(sum(arm_n[unlist(input$buckets$Ref)]), arm_n[unlist(input$buckets$Comp)]) |
| 634 |
} |
|
| 635 | ! |
validate(shiny::need( |
| 636 | ! |
all(anl_arm_n >= 2), |
| 637 | ! |
"Each treatment group should have at least 2 records." |
| 638 |
)) |
|
| 639 |
} |
|
| 640 | ||
| 641 |
# validate covariate has at least two levels |
|
| 642 | ! |
validate( |
| 643 | ! |
need( |
| 644 | ! |
all( |
| 645 | ! |
vapply( |
| 646 | ! |
merged$anl_q()[["ANL"]][input_cov_var], |
| 647 | ! |
FUN = function(x) {
|
| 648 | ! |
length(unique(x)) > 1 |
| 649 |
}, |
|
| 650 | ! |
logical(1) |
| 651 |
) |
|
| 652 |
), |
|
| 653 | ! |
"All covariates need to have at least two levels" |
| 654 |
) |
|
| 655 |
) |
|
| 656 |
}) |
|
| 657 | ||
| 658 | ! |
all_q <- reactive({
|
| 659 | ! |
validate_checks() |
| 660 | ||
| 661 | ! |
ANL <- merged$anl_q()[["ANL"]] |
| 662 | ||
| 663 | ! |
label_paramcd <- get_paramcd_label(ANL, paramcd) |
| 664 | ||
| 665 | ! |
paramcd <- as.character(unique(ANL[[unlist(paramcd$filter)["vars_selected"]]])) |
| 666 | ||
| 667 | ! |
interaction_var <- input$interaction_var |
| 668 | ! |
interaction_flag <- length(interaction_var) != 0 |
| 669 | ||
| 670 | ! |
at_values <- as_numeric_from_comma_sep_str(input$interaction_values) |
| 671 | ! |
at_flag <- interaction_flag && is.numeric(ANL[[interaction_var]]) |
| 672 | ||
| 673 | ! |
cov_var <- names(merged$anl_input_r()$columns_source$cov_var) |
| 674 | ||
| 675 | ! |
calls <- template_logistic( |
| 676 | ! |
dataname = "ANL", |
| 677 | ! |
arm_var = names(merged$anl_input_r()$columns_source$arm_var), |
| 678 | ! |
aval_var = names(merged$anl_input_r()$columns_source$avalc_var), |
| 679 | ! |
label_paramcd = label_paramcd, |
| 680 | ! |
cov_var = if (length(cov_var) > 0) cov_var else NULL, |
| 681 | ! |
interaction_var = if (interaction_flag) interaction_var else NULL, |
| 682 | ! |
ref_arm = unlist(input$buckets$Ref), |
| 683 | ! |
comp_arm = unlist(input$buckets$Comp), |
| 684 | ! |
combine_comp_arms = input$combine_comp_arms, |
| 685 | ! |
topleft = paramcd, |
| 686 | ! |
conf_level = as.numeric(input$conf_level), |
| 687 | ! |
at = if (at_flag) at_values else NULL, |
| 688 | ! |
responder_val = input$responders, |
| 689 | ! |
basic_table_args = basic_table_args |
| 690 |
) |
|
| 691 | ||
| 692 | ! |
teal.code::eval_code(merged$anl_q(), as.expression(calls)) |
| 693 |
}) |
|
| 694 | ||
| 695 | ! |
table_r <- reactive(all_q()[["result"]]) |
| 696 | ||
| 697 | ! |
teal.widgets::table_with_settings_srv( |
| 698 | ! |
id = "table", |
| 699 | ! |
table_r = table_r |
| 700 |
) |
|
| 701 | ||
| 702 | ! |
teal.widgets::verbatim_popup_srv( |
| 703 | ! |
id = "rcode", |
| 704 | ! |
verbatim_content = reactive(teal.code::get_code(all_q())), |
| 705 | ! |
title = label |
| 706 |
) |
|
| 707 | ||
| 708 |
### REPORTER |
|
| 709 | ! |
if (with_reporter) {
|
| 710 | ! |
card_fun <- function(comment, label) {
|
| 711 | ! |
card <- teal::report_card_template( |
| 712 | ! |
title = "Logistic Regression Table", |
| 713 | ! |
label = label, |
| 714 | ! |
with_filter = with_filter, |
| 715 | ! |
filter_panel_api = filter_panel_api |
| 716 |
) |
|
| 717 | ! |
card$append_text("Table", "header3")
|
| 718 | ! |
card$append_table(table_r()) |
| 719 | ! |
if (!comment == "") {
|
| 720 | ! |
card$append_text("Comment", "header3")
|
| 721 | ! |
card$append_text(comment) |
| 722 |
} |
|
| 723 | ! |
card$append_src(teal.code::get_code(all_q())) |
| 724 | ! |
card |
| 725 |
} |
|
| 726 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 727 |
} |
|
| 728 |
### |
|
| 729 |
}) |
|
| 730 |
} |
| 1 |
#' Validate standard input values for a teal module |
|
| 2 |
#' |
|
| 3 |
#' @description `r lifecycle::badge("stable")`
|
|
| 4 |
#' @param adsl data.frame with subject-level data |
|
| 5 |
#' @param adslvars required variables from `ADSL` |
|
| 6 |
#' @param anl data.frame with analysis data |
|
| 7 |
#' @param anlvars required variables from `ANL` |
|
| 8 |
#' @param need_arm flag indicating whether grouping variable `arm_var` |
|
| 9 |
#' is required or can be optionally `NULL`. |
|
| 10 |
#' @param arm_var character with name of grouping variable, typically arm |
|
| 11 |
#' @param ref_arm character with name of reference level in `arm_var` |
|
| 12 |
#' @param comp_arm character with name for comparison level in `arm_var` |
|
| 13 |
#' @param min_n_levels_armvar minimum number of levels in grouping variable `arm_var`. |
|
| 14 |
#' Defaults to 1, `NULL` for no minimum. |
|
| 15 |
#' @param max_n_levels_armvar maximum number of levels in grouping variable `arm_var`. |
|
| 16 |
#' Use `NULL` for no maximum. |
|
| 17 |
#' @param min_nrow minimum number of observations in `ADSL` and `ANL` |
|
| 18 |
#' |
|
| 19 |
#' @keywords internal |
|
| 20 |
#' |
|
| 21 |
validate_standard_inputs <- function(adsl, |
|
| 22 |
adslvars = character(0), |
|
| 23 |
anl, |
|
| 24 |
anlvars = character(0), |
|
| 25 |
need_arm = TRUE, |
|
| 26 |
arm_var, |
|
| 27 |
ref_arm, |
|
| 28 |
comp_arm, |
|
| 29 |
min_n_levels_armvar = 1L, |
|
| 30 |
max_n_levels_armvar = 100L, |
|
| 31 |
min_nrow = 1) {
|
|
| 32 | ! |
teal::validate_has_data(adsl, min_nrow = min_nrow) |
| 33 | ! |
teal::validate_has_data(anl, min_nrow = min_nrow) |
| 34 | ||
| 35 | ! |
if (length(adslvars) > 0) {
|
| 36 | ! |
teal::validate_has_variable(adsl, c(adslvars, arm_var)) |
| 37 |
} |
|
| 38 | ! |
if (length(anlvars) > 0) {
|
| 39 | ! |
teal::validate_has_variable(anl, anlvars) |
| 40 |
} |
|
| 41 | ||
| 42 | ! |
if (need_arm || (!(need_arm) && !is.null(arm_var))) {
|
| 43 | ! |
teal::validate_has_elements(arm_var, "Treatment variable name is empty.") |
| 44 | ! |
teal::validate_has_variable(adsl, arm_var, "Treatment variable not found.") |
| 45 | ||
| 46 | ! |
validate_n_levels( |
| 47 | ! |
adsl[[arm_var]], |
| 48 | ! |
min_levels = min_n_levels_armvar, |
| 49 | ! |
max_levels = max_n_levels_armvar, |
| 50 | ! |
var_name = arm_var |
| 51 |
) |
|
| 52 | ||
| 53 | ! |
validate_arm(adsl[[arm_var]]) |
| 54 | ||
| 55 | ! |
if (!missing(comp_arm)) {
|
| 56 | ! |
teal::validate_has_elements(comp_arm, "Comparison treatments selection is empty.") |
| 57 |
} |
|
| 58 | ! |
if (!missing(ref_arm)) {
|
| 59 | ! |
teal::validate_has_elements(ref_arm, "Reference treatments selection is empty.") |
| 60 |
} |
|
| 61 | ||
| 62 | ! |
if (!missing(comp_arm) && !missing(ref_arm)) {
|
| 63 | ! |
teal::validate_in( |
| 64 | ! |
c(comp_arm, ref_arm), adsl[[arm_var]], |
| 65 | ! |
"Current ADSL data does not have observations from the reference and comparison treatments." |
| 66 |
) |
|
| 67 |
} |
|
| 68 |
} |
|
| 69 |
} |
|
| 70 | ||
| 71 |
#' Check if vector is valid as to be used as a treatment arm variable |
|
| 72 |
#' |
|
| 73 |
#' @details A validate error is returned if the vector is not a factor with a more detailed |
|
| 74 |
#' error message if any of the entries are empty strings |
|
| 75 |
#' @param arm_vec vector to be validated |
|
| 76 |
#' @keywords internal |
|
| 77 |
#' |
|
| 78 |
validate_arm <- function(arm_vec) {
|
|
| 79 | 6x |
validate(shiny::need(is.factor(arm_vec), "Treatment variable is not a factor")) |
| 80 | 4x |
validate( |
| 81 | 4x |
need( |
| 82 | 4x |
all(trimws(levels(arm_vec)) != ""), |
| 83 | 4x |
"Treatment values cannot contain empty strings" |
| 84 |
) |
|
| 85 |
) |
|
| 86 |
} |
| 1 |
# This file contains functions that help with plotting in other modules |
|
| 2 | ||
| 3 |
#' Facetting formula `x_facet ~ y_facet` |
|
| 4 |
#' |
|
| 5 |
#' @description `r lifecycle::badge("stable")`
|
|
| 6 |
#' Replaces `x_facet` or `y_facet` by . when empty character |
|
| 7 |
#' |
|
| 8 |
#' @md |
|
| 9 |
#' @param x_facet (`character(1)`)\cr |
|
| 10 |
#' name of x facet, if empty, will not facet along x. |
|
| 11 |
#' @param y_facet (`character(1)`)\cr |
|
| 12 |
#' name of y facet, if empty, will not facet along y. |
|
| 13 |
#' |
|
| 14 |
#' @return facet grid formula `formula(x_facet ~ y_facet)` |
|
| 15 |
#' |
|
| 16 |
#' @keywords internal |
|
| 17 |
#' |
|
| 18 |
facet_grid_formula <- function(x_facet, y_facet) {
|
|
| 19 | 1x |
if (length(x_facet) == 0) x_facet <- "." |
| 20 | 2x |
if (length(y_facet) == 0) y_facet <- "." |
| 21 | 4x |
checkmate::assert_string(x_facet) |
| 22 | 4x |
checkmate::assert_string(y_facet) |
| 23 | ! |
if (x_facet == y_facet) stop("'x_facet' and 'y_facet' must not be equal.")
|
| 24 | 4x |
stats::as.formula(paste0(y_facet, " ~ ", x_facet)) # must invert it |
| 25 |
} |
| 1 |
#' Get full label, useful for annotating plots |
|
| 2 |
#' |
|
| 3 |
#' @param dataset (`data.frame`)\cr dataset |
|
| 4 |
#' @param column (`character`)\cr column to get label from |
|
| 5 |
#' @param omit_raw_name (`logical`)\cr omits the raw name in square brackets if label is found |
|
| 6 |
#' |
|
| 7 |
#' @return "Label `[Column name]`" if label exists, otherwise "Column name". |
|
| 8 |
#' |
|
| 9 |
#' @examples |
|
| 10 |
#' data <- mtcars |
|
| 11 |
#' column_annotation_label(data, "cyl") |
|
| 12 |
#' attr(data[["cyl"]], "label") <- "Cylinder" |
|
| 13 |
#' column_annotation_label(data, "cyl") |
|
| 14 |
#' column_annotation_label(data, "cyl", omit_raw_name = TRUE) |
|
| 15 |
#' column_annotation_label(tmc_ex_adsl, "ACTARM") |
|
| 16 |
#' @export |
|
| 17 |
column_annotation_label <- function(dataset, column, omit_raw_name = FALSE) {
|
|
| 18 | ! |
checkmate::assert_data_frame(dataset) |
| 19 | ! |
checkmate::assert_string(column) |
| 20 | ! |
checkmate::assert_flag(omit_raw_name) |
| 21 | ||
| 22 | ! |
if (is.null(attr(dataset[[column]], "label"))) {
|
| 23 | ! |
column |
| 24 |
} else {
|
|
| 25 | ! |
col_label <- attr(dataset[[column]], "label") |
| 26 | ! |
if (omit_raw_name) {
|
| 27 | ! |
col_label |
| 28 |
} else {
|
|
| 29 | ! |
sprintf("%s [%s]", col_label, column)
|
| 30 |
} |
|
| 31 |
} |
|
| 32 |
} |
| 1 |
.onLoad <- function(libname, pkgname) {
|
|
| 2 | ! |
teal.logger::register_logger(namespace = "teal.modules.clinical") |
| 3 | ! |
teal.logger::register_handlers("teal.modules.clinical")
|
| 4 | ! |
tern::set_default_na_str("<Missing>")
|
| 5 |
} |